repos / kde.examples / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Replace mudballs with ASDF and support the modular Smoke.
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 :cl-smoke.kde.examples)
2009-04-02 tobias 17
22:16:06 ' 18 (defun zoom-in-factor ()
' 19 0.8)
' 20
' 21 (defun zoom-out-factor ()
' 22 (/ (zoom-in-factor)))
' 23
' 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))
' 34
' 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)))
' 42
' 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))
' 48 (mapcar #'find-class
' 49 '(qt:image double-float))))
' 50 (qt:connect (done-signal *render-control*)
' 51 (update-pixmap-slot mandelbrotwidget)
' 52 qt:+queued-connection+))
' 53
' 54 (defun draw-rendering (painter widget)
2009-04-17 tobias 55 (cxx:set-pen painter #xFFFFFF) ;; FIXME make qt:+white+ work
2009-04-02 tobias 56 (cxx:draw-text painter (cxx:rect widget)
22:16:06 ' 57 (value qt:+align-center+)
' 58 "Rendering initial image, please wait..."))
' 59
' 60 (defun complex-floor (complex)
' 61 "Applys FLOOR to the real and imaginary part of COMPLEX."
' 62 (complex (floor (realpart complex)
' 63 (imagpart complex))))
' 64
' 65 (defun draw-scaled-pixmap (painter widget)
' 66 (cxx:save painter) ;; FIXME make with- macro
' 67 (let* ((scale-factor (/ (pixmap-scale widget)
' 68 (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))
' 76 (cxx:rect widget))
' 77 -1 -1 1 1)))
' 78 (cxx:draw-pixmap painter exposed (pixmap widget) exposed)))
' 79 (cxx:restore painter))
' 80
' 81
' 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)))
' 87 (pixmap widget))
' 88 (draw-scaled-pixmap painter widget)))
' 89
2009-04-12 tobias 90 (defmethod cxx:paint-event ((widget mandelbrotwidget) event)
13:34:59 ' 91 (declare (ignore event))
2009-04-02 tobias 92 (qt:with-painter (painter widget)
22:16:06 ' 93 (cxx:fill-rect painter (cxx:rect widget)
2009-04-17 tobias 94 #x000) ;; FIXME qt:+black+
2009-04-02 tobias 95 (if (null (pixmap widget))
22:16:06 ' 96 (draw-rendering painter widget)
' 97 (draw-pixmap painter widget))))
' 98
2009-04-12 tobias 99 (defmethod cxx:resize-event ((widget mandelbrotwidget) event)
13:34:59 ' 100 (declare (ignore event))
2009-04-02 tobias 101 (when (slot-boundp widget 'render)
22:16:06 ' 102 (setf (stop-p *render-control*) t)
' 103 (join-thread (slot-value widget 'render)))
' 104 (queue-image widget))
' 105
2009-04-12 tobias 106 (defmethod cxx:key-press-event ((widget mandelbrotwidget) event)
2009-04-02 tobias 107 (enum-cases (cxx:key event)
22:16:06 ' 108 (qt:+key-up+
' 109 (scroll widget #C(0d0 -5d0)))
' 110 (qt:+key-down+
' 111 (scroll widget #C(0d0 5d0)))
' 112 (qt:+key-left+
' 113 (scroll widget #C(-5d0 0d0)))
' 114 (qt:+key-right+
' 115 (scroll widget #C(5d0 0d0)))
' 116 (qt:+key-plus+
' 117 (zoom widget (zoom-in-factor)))
' 118 (qt:+key-minus+
' 119 (zoom widget (zoom-out-factor)))))
' 120
2009-04-12 tobias 121 (defmethod cxx:mouse-press-event ((widget mandelbrotwidget) event)
2009-04-02 tobias 122 (when (enum= (cxx:button event) qt:+left-button+)
22:16:06 ' 123 (setf (last-drag-pos widget) (complex (cxx:x event)
' 124 (cxx:y event)))))
' 125
2009-04-12 tobias 126 (defmethod cxx:wheel-event ((widget mandelbrotwidget) event)
2009-04-02 tobias 127 (zoom widget (expt (zoom-in-factor) (/ (cxx:delta event) (* 8 15.0)))))
22:16:06 ' 128
2009-04-12 tobias 129 (defmethod cxx:mouse-move-event ((widget mandelbrotwidget) event)
2010-04-03 tobias 130 (when (and (logand (cxx:buttons event) (value qt:+left-button+))
17:19:09 ' 131 (last-drag-pos widget))
2009-04-02 tobias 132 (incf (pixmap-offset widget)
22:16:06 ' 133 (- (complex (cxx:x event)
' 134 (cxx:y event))
' 135 (last-drag-pos widget)))
' 136 (setf (last-drag-pos widget) (complex (cxx:x event)
' 137 (cxx:y event)))
' 138 (cxx:update widget)))
' 139
2009-04-12 tobias 140 (defmethod cxx:mouse-release-event ((widget mandelbrotwidget) event)
2009-04-02 tobias 141 (when (enum= (cxx:button event) qt:+left-button+)
22:16:06 ' 142 (incf (pixmap-offset widget)
' 143 (- (complex (cxx:x event)
' 144 (cxx:y 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))))))
' 152
' 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)
' 158 (scale widget)
' 159 (cxx:width widget)
' 160 (cxx:height widget)
' 161 *render-control*))))
' 162
' 163 (defun zoom (widget factor)
' 164 (setf (scale widget) (* (scale widget) factor))
' 165 (cxx:update widget)
' 166 (queue-image widget))
' 167
' 168 (defun scroll (widget delta)
' 169 (incf (center widget) (* (scale widget) delta))
' 170 (cxx:update widget)
' 171 (queue-image widget))
Crece desde el pueblo el futuro / crece desde el pie