diff options
| -rw-r--r-- | examples/14-canvas-paint.lisp | 33 |
1 files changed, 27 insertions, 6 deletions
diff --git a/examples/14-canvas-paint.lisp b/examples/14-canvas-paint.lisp index 35c74ba..3db904e 100644 --- a/examples/14-canvas-paint.lisp +++ b/examples/14-canvas-paint.lisp @@ -6,7 +6,8 @@ (in-package #:ww.examples/14) -(defclass pixel-whomp (ww:application) ()) +(defclass pixel-whomp (ww:application) + ()) (defclass pwcanvas (ww:canvas) ((pen-down-pos :accessor pen-down-pos :initform nil) @@ -61,27 +62,36 @@ (ww::on-keyup () (setf (mode target) :draw))) + (ww::defhandler zoom - (ww::on-mousewheel (target h v) - (format t "v: ~a~% " v) - (ww:scale-by target - (if (plusp v) 1.1 0.9)))) + (ww::on-mousewheel (u h v) + (multiple-value-bind + (ox oy) + (apply #'scale-pos-to-canvas u *last-mouse-pos*) + (ww:scale-by u (if (plusp v) 1.1 0.9)) + (multiple-value-bind + (nx ny) + (apply #'scale-pos-to-canvas u *last-mouse-pos*) + (incf (ww:x u) (* (ww:scale-x u) (- nx ox))) + (incf (ww:y u) (* (ww:scale-x u) (- ny oy))))))) (ww:defhandler canvas-mousebutton-down (ww:on-mousedown (target x y clicks button winx winy) (unless (pen-down-pos target) (set-pen-position target x y) (when (eq :draw (mode target)) - (format t "foo") (ww::with-canvas target (ww:with-pen (:width (pen-width target)) (apply 'ww:apply-pen-at (mapcar #'floor (pen-down-pos target)))) (ww:blit target)))))) + (ww::defhandler canvas-mousebutton-up (ww::on-mouseup (target) (setf (pen-down-pos target) nil))) + + (defun draw (canvas x y) (let ((old-pos (copy-seq (pen-down-pos canvas)))) (destructuring-bind (nx ny) (set-pen-position canvas x y) @@ -100,6 +110,15 @@ (incf (ww:x canvas) tx) (incf (ww:y canvas) ty))))) +(defvar *last-mouse-pos* (list 0 0)) + + + +(ww::defhandler moust-tracker + (ww::on-mousemotion (target x y) + (setf (car *last-mouse-pos*) x + (cadr *last-mouse-pos*) y))) + (ww::defhandler canvas-mouse-move (ww::on-mousemotion (target x y) (when (pen-down-pos target) @@ -121,6 +140,8 @@ (make-instance 'pwcanvas :pixel-width 800 :pixel-height 800))) + (ww:add-handler app #'moust-tracker) + (ww:add-handler canvas #'moust-tracker) (ww:add-unit canvas))) (defun start () |