Fri Apr 3 00:16:06 CEST 2009 Tobias Rautenkranz * initial import --- old-kde.examples/src/mandelbrot/mandelbrotwidget.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-kde.examples/src/mandelbrot/mandelbrotwidget.lisp 2014-10-30 08:41:56.000000000 +0100 @@ -0,0 +1,163 @@ +(in-package :kde.examples) +(declaim (optimize (debug 3))) + +(defun zoom-in-factor () + 0.8) + +(defun zoom-out-factor () + (/ (zoom-in-factor))) + +(defclass mandelbrotwidget (qt:widget) + ((pixmap :accessor pixmap :initform nil) + (pixmap-scale :accessor pixmap-scale) + (pixmap-offset :accessor pixmap-offset) + (center :accessor center :initform #C(-0.5d0 0d0)) + (scale :accessor scale :initform 0.007d0) + (update-pixmap-slot :accessor update-pixmap-slot) + (render :accessor render-thread) + (last-drag-pos :accessor last-drag-pos :initform nil)) + (:metaclass cxx:class)) + +(defun update-pixmap (mandelbrotwidget image scale) + (when (null (last-drag-pos mandelbrotwidget)) + (setf (pixmap mandelbrotwidget) + (qt:pixmap.from-image image)) + (setf (pixmap-offset mandelbrotwidget) #c(0 0)) + (setf (pixmap-scale mandelbrotwidget) scale) + (cxx:update mandelbrotwidget))) + +(defparameter *render-control* (make-instance 'render-control)) +(defun setup-slot (mandelbrotwidget) + (setf (update-pixmap-slot mandelbrotwidget) + (qt:make-slot #'(lambda (image scale) + (update-pixmap mandelbrotwidget image scale)) + (mapcar #'find-class + '(qt:image double-float)))) + (qt:connect (done-signal *render-control*) + (update-pixmap-slot mandelbrotwidget) + qt:+queued-connection+)) + +(defun draw-rendering (painter widget) + (cxx:set-pen painter (make-instance 'qt:color + :args (list qt:+white+))) + (cxx:draw-text painter (cxx:rect widget) + (value qt:+align-center+) + "Rendering initial image, please wait...")) + +(defun complex-floor (complex) + "Applys FLOOR to the real and imaginary part of COMPLEX." + (complex (floor (realpart complex) + (imagpart complex)))) + +(defun draw-scaled-pixmap (painter widget) + (cxx:save painter) ;; FIXME make with- macro + (let* ((scale-factor (/ (pixmap-scale widget) + (scale widget))) + (pixmap-size (complex (cxx:width (pixmap widget)) + (cxx:height (pixmap widget)))) + (new-size (* scale-factor pixmap-size)) + (new-center (+ (pixmap-offset widget) (/ (- pixmap-size new-size) 2)))) + (cxx:translate painter (realpart new-center) (imagpart new-center)) + (cxx:scale painter scale-factor scale-factor) + (let ((exposed (cxx:adjusted (cxx:map-rect (cxx:inverted (cxx:matrix painter)) + (cxx:rect widget)) + -1 -1 1 1))) + (cxx:draw-pixmap painter exposed (pixmap widget) exposed))) + (cxx:restore painter)) + + +(defun draw-pixmap (painter widget) + (if (= (scale widget) (pixmap-scale widget)) + (cxx:draw-pixmap painter + (floor (realpart (pixmap-offset widget))) + (floor (imagpart (pixmap-offset widget))) + (pixmap widget)) + (draw-scaled-pixmap painter widget))) + +(defmethod cxx:paint-event ((widget mandelbrotwidget) &rest args) + (declare (ignore args)) + (qt:with-painter (painter widget) + (cxx:fill-rect painter (cxx:rect widget) + (make-instance 'qt:brush :args (list + (make-instance 'qt:color :args (list qt:+black+))))) + (if (null (pixmap widget)) + (draw-rendering painter widget) + (draw-pixmap painter widget)))) + +(defmethod cxx:resize-event ((widget mandelbrotwidget) &rest args) + (declare (ignore args)) + (when (slot-boundp widget 'render) + (setf (stop-p *render-control*) t) + (join-thread (slot-value widget 'render))) + (queue-image widget)) + +(defmethod cxx:key-press-event ((widget mandelbrotwidget) &rest args + &aux (event (first args))) + (enum-cases (cxx:key event) + (qt:+key-up+ + (scroll widget #C(0d0 -5d0))) + (qt:+key-down+ + (scroll widget #C(0d0 5d0))) + (qt:+key-left+ + (scroll widget #C(-5d0 0d0))) + (qt:+key-right+ + (scroll widget #C(5d0 0d0))) + (qt:+key-plus+ + (zoom widget (zoom-in-factor))) + (qt:+key-minus+ + (zoom widget (zoom-out-factor))))) + +(defmethod cxx:mouse-press-event ((widget mandelbrotwidget) &rest args + &aux (event (first args))) + (when (enum= (cxx:button event) qt:+left-button+) + (setf (last-drag-pos widget) (complex (cxx:x event) + (cxx:y event))))) + +(defmethod cxx:wheel-event ((widget mandelbrotwidget) &rest args + &aux (event (first args))) + (zoom widget (expt (zoom-in-factor) (/ (cxx:delta event) (* 8 15.0))))) + +(defmethod cxx:mouse-move-event ((widget mandelbrotwidget) &rest args + &aux (event (first args))) + (when (logand (cxx:buttons event) (value qt:+left-button+)) + (incf (pixmap-offset widget) + (- (complex (cxx:x event) + (cxx:y event)) + (last-drag-pos widget))) + (setf (last-drag-pos widget) (complex (cxx:x event) + (cxx:y event))) + (cxx:update widget))) + +(defmethod cxx:mouse-release-event ((widget mandelbrotwidget) &rest args + &aux (event (first args))) + (when (enum= (cxx:button event) qt:+left-button+) + (incf (pixmap-offset widget) + (- (complex (cxx:x event) + (cxx:y event)) + (last-drag-pos widget))) + (setf (last-drag-pos widget) nil) + (let ((pixmap-size (complex (cxx:width (pixmap widget)) + (cxx:height (pixmap widget)))) + (size (complex (cxx:width widget) + (cxx:height widget)))) + (scroll widget (- (/ (- size pixmap-size) 2) (pixmap-offset widget)))))) + +(defun queue-image (widget) + (setf (stop-p *render-control*) nil) + ;; FIXME do not creating a new thread on every invokation + (setf (render-thread widget) + (make-thread (make-render-function (center widget) + (scale widget) + (cxx:width widget) + (cxx:height widget) + *render-control*)))) + +(defun zoom (widget factor) + (setf (scale widget) (* (scale widget) factor)) + (cxx:update widget) + (queue-image widget)) + +(defun scroll (widget delta) + (incf (center widget) (* (scale widget) delta)) + (cxx:update widget) + (queue-image widget))