1 ;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
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.
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.
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/>.
16 (in-package :cl-smoke.kde.examples)
18 (defun zoom-in-factor ()
21 (defun zoom-out-factor ()
24 (defclass mandelbrotwidget (qt:widget)
25 ((pixmap :accessor pixmap :initform nil)
26 (pixmap-scale :accessor pixmap-scale)
27 (pixmap-offset :accessor pixmap-offset)
28 (center :accessor center :initform #C(-0.5d0 0d0))
29 (scale :accessor scale :initform 0.007d0)
30 (update-pixmap-slot :accessor update-pixmap-slot)
31 (render :accessor render-thread)
32 (last-drag-pos :accessor last-drag-pos :initform nil))
33 (:metaclass cxx:class))
35 (defun update-pixmap (mandelbrotwidget image scale)
36 (when (null (last-drag-pos mandelbrotwidget))
37 (setf (pixmap mandelbrotwidget)
38 (qt:pixmap.from-image image))
39 (setf (pixmap-offset mandelbrotwidget) #c(0 0))
40 (setf (pixmap-scale mandelbrotwidget) scale)
41 (cxx:update mandelbrotwidget)))
43 (defparameter *render-control* (make-instance 'render-control))
44 (defun setup-slot (mandelbrotwidget)
45 (setf (update-pixmap-slot mandelbrotwidget)
46 (qt:make-slot #'(lambda (image scale)
47 (update-pixmap mandelbrotwidget image scale))
49 '(qt:image double-float))))
50 (qt:connect (done-signal *render-control*)
51 (update-pixmap-slot mandelbrotwidget)
52 qt:+queued-connection+))
54 (defun draw-rendering (painter widget)
55 (cxx:set-pen painter #xFFFFFF) ;; FIXME make qt:+white+ work
56 (cxx:draw-text painter (cxx:rect widget)
57 (value qt:+align-center+)
58 "Rendering initial image, please wait..."))
60 (defun complex-floor (complex)
61 "Applys FLOOR to the real and imaginary part of COMPLEX."
62 (complex (floor (realpart complex)
65 (defun draw-scaled-pixmap (painter widget)
66 (cxx:save painter) ;; FIXME make with- macro
67 (let* ((scale-factor (/ (pixmap-scale widget)
69 (pixmap-size (complex (cxx:width (pixmap widget))
70 (cxx:height (pixmap widget))))
71 (new-size (* scale-factor pixmap-size))
72 (new-center (+ (pixmap-offset widget) (/ (- pixmap-size new-size) 2))))
73 (cxx:translate painter (realpart new-center) (imagpart new-center))
74 (cxx:scale painter scale-factor scale-factor)
75 (let ((exposed (cxx:adjusted (cxx:map-rect (cxx:inverted (cxx:matrix painter))
78 (cxx:draw-pixmap painter exposed (pixmap widget) exposed)))
79 (cxx:restore painter))
82 (defun draw-pixmap (painter widget)
83 (if (= (scale widget) (pixmap-scale widget))
84 (cxx:draw-pixmap painter
85 (floor (realpart (pixmap-offset widget)))
86 (floor (imagpart (pixmap-offset widget)))
88 (draw-scaled-pixmap painter widget)))
90 (defmethod cxx:paint-event ((widget mandelbrotwidget) event)
91 (declare (ignore event))
92 (qt:with-painter (painter widget)
93 (cxx:fill-rect painter (cxx:rect widget)
94 #x000) ;; FIXME qt:+black+
95 (if (null (pixmap widget))
96 (draw-rendering painter widget)
97 (draw-pixmap painter widget))))
99 (defmethod cxx:resize-event ((widget mandelbrotwidget) event)
100 (declare (ignore event))
101 (when (slot-boundp widget 'render)
102 (setf (stop-p *render-control*) t)
103 (join-thread (slot-value widget 'render)))
104 (queue-image widget))
106 (defmethod cxx:key-press-event ((widget mandelbrotwidget) event)
107 (enum-cases (cxx:key event)
109 (scroll widget #C(0d0 -5d0)))
111 (scroll widget #C(0d0 5d0)))
113 (scroll widget #C(-5d0 0d0)))
115 (scroll widget #C(5d0 0d0)))
117 (zoom widget (zoom-in-factor)))
119 (zoom widget (zoom-out-factor)))))
121 (defmethod cxx:mouse-press-event ((widget mandelbrotwidget) event)
122 (when (enum= (cxx:button event) qt:+left-button+)
123 (setf (last-drag-pos widget) (complex (cxx:x event)
126 (defmethod cxx:wheel-event ((widget mandelbrotwidget) event)
127 (zoom widget (expt (zoom-in-factor) (/ (cxx:delta event) (* 8 15.0)))))
129 (defmethod cxx:mouse-move-event ((widget mandelbrotwidget) event)
130 (when (and (logand (cxx:buttons event) (value qt:+left-button+))
131 (last-drag-pos widget))
132 (incf (pixmap-offset widget)
133 (- (complex (cxx:x event)
135 (last-drag-pos widget)))
136 (setf (last-drag-pos widget) (complex (cxx:x event)
138 (cxx:update widget)))
140 (defmethod cxx:mouse-release-event ((widget mandelbrotwidget) event)
141 (when (enum= (cxx:button event) qt:+left-button+)
142 (incf (pixmap-offset widget)
143 (- (complex (cxx:x event)
145 (last-drag-pos widget)))
146 (setf (last-drag-pos widget) nil)
147 (let ((pixmap-size (complex (cxx:width (pixmap widget))
148 (cxx:height (pixmap widget))))
149 (size (complex (cxx:width widget)
150 (cxx:height widget))))
151 (scroll widget (- (/ (- size pixmap-size) 2) (pixmap-offset widget))))))
153 (defun queue-image (widget)
154 (setf (stop-p *render-control*) nil)
155 ;; FIXME do not creating a new thread on every invokation
156 (setf (render-thread widget)
157 (make-thread (make-render-function (center widget)
163 (defun zoom (widget factor)
164 (setf (scale widget) (* (scale widget) factor))
166 (queue-image widget))
168 (defun scroll (widget delta)
169 (incf (center widget) (* (scale widget) delta))
171 (queue-image widget))