repos
/
kde.examples
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
License
Annotate for file src/mandelbrot/mandelbrotwidget.lisp
2009-04-14 tobias
1
;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
14:32:06 '
2
;;;
'
3
;;; This program is free software: you can redistribute it and/or modify
'
4
;;; it under the terms of the GNU General Public License as published by
'
5
;;; the Free Software Foundation, either version 3 of the License, or
'
6
;;; (at your option) any later version.
'
7
;;;
'
8
;;; This program is distributed in the hope that it will be useful,
'
9
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
'
10
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
'
11
;;; GNU General Public License for more details.
'
12
;;;
'
13
;;; You should have received a copy of the GNU General Public License
'
14
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
'
15
2010-04-03 tobias
16
(in-package :kde.examples)
17:19:09 '
17
(declaim (optimize (debug 3)))
2009-04-02 tobias
18
22:16:06 '
19
(defun zoom-in-factor ()
'
20
0.8)
'
21
'
22
(defun zoom-out-factor ()
'
23
(/ (zoom-in-factor)))
'
24
'
25
(defclass mandelbrotwidget (qt:widget)
'
26
((pixmap :accessor pixmap :initform nil)
'
27
(pixmap-scale :accessor pixmap-scale)
'
28
(pixmap-offset :accessor pixmap-offset)
'
29
(center :accessor center :initform #C(-0.5d0 0d0))
'
30
(scale :accessor scale :initform 0.007d0)
'
31
(update-pixmap-slot :accessor update-pixmap-slot)
'
32
(render :accessor render-thread)
'
33
(last-drag-pos :accessor last-drag-pos :initform nil))
'
34
(:metaclass cxx:class))
'
35
'
36
(defun update-pixmap (mandelbrotwidget image scale)
'
37
(when (null (last-drag-pos mandelbrotwidget))
'
38
(setf (pixmap mandelbrotwidget)
'
39
(qt:pixmap.from-image image))
'
40
(setf (pixmap-offset mandelbrotwidget) #c(0 0))
'
41
(setf (pixmap-scale mandelbrotwidget) scale)
'
42
(cxx:update mandelbrotwidget)))
'
43
'
44
(defparameter *render-control* (make-instance 'render-control))
'
45
(defun setup-slot (mandelbrotwidget)
'
46
(setf (update-pixmap-slot mandelbrotwidget)
'
47
(qt:make-slot #'(lambda (image scale)
'
48
(update-pixmap mandelbrotwidget image scale))
'
49
(mapcar #'find-class
'
50
'(qt:image double-float))))
'
51
(qt:connect (done-signal *render-control*)
'
52
(update-pixmap-slot mandelbrotwidget)
'
53
qt:+queued-connection+))
'
54
'
55
(defun draw-rendering (painter widget)
2009-04-17 tobias
56
(cxx:set-pen painter (make-instance 'qt:color
15:30:05 '
57
:args (list qt:+white+)))
2009-04-02 tobias
58
(cxx:draw-text painter (cxx:rect widget)
22:16:06 '
59
(value qt:+align-center+)
'
60
"Rendering initial image, please wait..."))
'
61
'
62
(defun complex-floor (complex)
'
63
"Applys FLOOR to the real and imaginary part of COMPLEX."
'
64
(complex (floor (realpart complex)
'
65
(imagpart complex))))
'
66
'
67
(defun draw-scaled-pixmap (painter widget)
'
68
(cxx:save painter) ;; FIXME make with- macro
'
69
(let* ((scale-factor (/ (pixmap-scale widget)
'
70
(scale widget)))
'
71
(pixmap-size (complex (cxx:width (pixmap widget))
'
72
(cxx:height (pixmap widget))))
'
73
(new-size (* scale-factor pixmap-size))
'
74
(new-center (+ (pixmap-offset widget) (/ (- pixmap-size new-size) 2))))
'
75
(cxx:translate painter (realpart new-center) (imagpart new-center))
'
76
(cxx:scale painter scale-factor scale-factor)
'
77
(let ((exposed (cxx:adjusted (cxx:map-rect (cxx:inverted (cxx:matrix painter))
'
78
(cxx:rect widget))
'
79
-1 -1 1 1)))
'
80
(cxx:draw-pixmap painter exposed (pixmap widget) exposed)))
'
81
(cxx:restore painter))
'
82
'
83
'
84
(defun draw-pixmap (painter widget)
'
85
(if (= (scale widget) (pixmap-scale widget))
'
86
(cxx:draw-pixmap painter
'
87
(floor (realpart (pixmap-offset widget)))
'
88
(floor (imagpart (pixmap-offset widget)))
'
89
(pixmap widget))
'
90
(draw-scaled-pixmap painter widget)))
'
91
2009-04-12 tobias
92
(defmethod cxx:paint-event ((widget mandelbrotwidget) event)
13:34:59 '
93
(declare (ignore event))
2009-04-02 tobias
94
(qt:with-painter (painter widget)
22:16:06 '
95
(cxx:fill-rect painter (cxx:rect widget)
2009-04-17 tobias
96
(make-instance 'qt:brush :args (list
15:30:05 '
97
(make-instance 'qt:color :args (list qt:+black+)))))
2009-04-02 tobias
98
(if (null (pixmap widget))
22:16:06 '
99
(draw-rendering painter widget)
'
100
(draw-pixmap painter widget))))
'
101
2009-04-12 tobias
102
(defmethod cxx:resize-event ((widget mandelbrotwidget) event)
13:34:59 '
103
(declare (ignore event))
2009-04-02 tobias
104
(when (slot-boundp widget 'render)
22:16:06 '
105
(setf (stop-p *render-control*) t)
'
106
(join-thread (slot-value widget 'render)))
'
107
(queue-image widget))
'
108
2009-04-12 tobias
109
(defmethod cxx:key-press-event ((widget mandelbrotwidget) event)
2009-04-02 tobias
110
(enum-cases (cxx:key event)
22:16:06 '
111
(qt:+key-up+
'
112
(scroll widget #C(0d0 -5d0)))
'
113
(qt:+key-down+
'
114
(scroll widget #C(0d0 5d0)))
'
115
(qt:+key-left+
'
116
(scroll widget #C(-5d0 0d0)))
'
117
(qt:+key-right+
'
118
(scroll widget #C(5d0 0d0)))
'
119
(qt:+key-plus+
'
120
(zoom widget (zoom-in-factor)))
'
121
(qt:+key-minus+
'
122
(zoom widget (zoom-out-factor)))))
'
123
2009-04-12 tobias
124
(defmethod cxx:mouse-press-event ((widget mandelbrotwidget) event)
2009-04-02 tobias
125
(when (enum= (cxx:button event) qt:+left-button+)
22:16:06 '
126
(setf (last-drag-pos widget) (complex (cxx:x event)
'
127
(cxx:y event)))))
'
128
2009-04-12 tobias
129
(defmethod cxx:wheel-event ((widget mandelbrotwidget) event)
2009-04-02 tobias
130
(zoom widget (expt (zoom-in-factor) (/ (cxx:delta event) (* 8 15.0)))))
22:16:06 '
131
2009-04-12 tobias
132
(defmethod cxx:mouse-move-event ((widget mandelbrotwidget) event)
2010-04-03 tobias
133
(when (logand (cxx:buttons event) (value qt:+left-button+))
2009-04-02 tobias
134
(incf (pixmap-offset widget)
22:16:06 '
135
(- (complex (cxx:x event)
'
136
(cxx:y event))
'
137
(last-drag-pos widget)))
'
138
(setf (last-drag-pos widget) (complex (cxx:x event)
'
139
(cxx:y event)))
'
140
(cxx:update widget)))
'
141
2009-04-12 tobias
142
(defmethod cxx:mouse-release-event ((widget mandelbrotwidget) event)
2009-04-02 tobias
143
(when (enum= (cxx:button event) qt:+left-button+)
22:16:06 '
144
(incf (pixmap-offset widget)
'
145
(- (complex (cxx:x event)
'
146
(cxx:y event))
'
147
(last-drag-pos widget)))
'
148
(setf (last-drag-pos widget) nil)
'
149
(let ((pixmap-size (complex (cxx:width (pixmap widget))
'
150
(cxx:height (pixmap widget))))
'
151
(size (complex (cxx:width widget)
'
152
(cxx:height widget))))
'
153
(scroll widget (- (/ (- size pixmap-size) 2) (pixmap-offset widget))))))
'
154
'
155
(defun queue-image (widget)
'
156
(setf (stop-p *render-control*) nil)
'
157
;; FIXME do not creating a new thread on every invokation
'
158
(setf (render-thread widget)
'
159
(make-thread (make-render-function (center widget)
'
160
(scale widget)
'
161
(cxx:width widget)
'
162
(cxx:height widget)
'
163
*render-control*))))
'
164
'
165
(defun zoom (widget factor)
'
166
(setf (scale widget) (* (scale widget) factor))
'
167
(cxx:update widget)
'
168
(queue-image widget))
'
169
'
170
(defun scroll (widget delta)
'
171
(incf (center widget) (* (scale widget) delta))
'
172
(cxx:update widget)
'
173
(queue-image widget))