Fri Apr 3 00:16:06 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* 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 07:20:21.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))