diff options
| -rw-r--r-- | examples/14-canvas-paint.lisp | 108 |
1 files changed, 93 insertions, 15 deletions
diff --git a/examples/14-canvas-paint.lisp b/examples/14-canvas-paint.lisp index bca6a13..35c74ba 100644 --- a/examples/14-canvas-paint.lisp +++ b/examples/14-canvas-paint.lisp @@ -9,33 +9,111 @@ (defclass pixel-whomp (ww:application) ()) (defclass pwcanvas (ww:canvas) - ((pen-down-p :accessor pen-down-p :initform nil))) + ((pen-down-pos :accessor pen-down-pos :initform nil) + (mode :initform :draw :accessor mode) + (pen-width :initform 1 :accessor pen-width))) +(defun scale-pos-to-canvas (can ex ey) + (let + ((scale (ww::scale-x can)) + (x (ww:x can)) + (y (ww:y can))) + (values (/ (- ex x) scale) + (/ (- ey y) scale)))) + +(defun set-pen-position (can ex ey) + "x and y are as received from mouse events. adjust the pen position + to account for scale, or set to nil of x and y are curren toff the + canvas" + (let + ((pos + (or (pen-down-pos can) + (list 0 0)))) + (multiple-value-bind (nx ny) (scale-pos-to-canvas can ex ey) + (setf (car pos) nx + (cadr pos) ny + (pen-down-pos can) pos)) + pos)) + +(defun shift-mod-p (mods) + (or (member :rshift mods) + (member :lshift mods))) + +(ww::defhandler keyboard-commands + (ww::on-keydown (target scancode mods) + (format t "~a~%" + (list :code scancode :mods mods)) + (case scancode + (:scancode-equals + (when (shift-mod-p mods) + (incf (pen-width target)))) + (:scancode-minus + (setf (pen-width target) + (max 0 (1- (pen-width target)))))))) + +(ww::defhandler change-mode-start + (ww::on-keydown () + (case scancode + ((:scancode-lshift :scancode-rshift) + (setf (mode target) :drag))))) + +(ww::defhandler change-mode-stop + (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:defhandler canvas-mousebutton-down (ww:on-mousedown (target x y clicks button winx winy) - (format t "(~a,~a) :clicks ~a :button ~a :winx ~a :winy ~a~%" - x y clicks button winx winy) - (unless (pen-down-p target) - (setf (pen-down-p target) (list x y))))) + (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-p target) nil))) + (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) + (ww:with-canvas canvas + (ww:with-pen (:position old-pos :width (pen-width canvas)) + (ww:stroke-to nx ny)))) + (ww:blit canvas))) + +(defun drag (canvas x y) + (multiple-value-bind (cx cy) (scale-pos-to-canvas canvas x y) + (destructuring-bind (px py) (pen-down-pos canvas) + (let ((tx (* (ww:scale-x canvas) + (- cx px))) + (ty (* (ww:scale-x canvas) + (- cy py)))) + (incf (ww:x canvas) tx) + (incf (ww:y canvas) ty))))) (ww::defhandler canvas-mouse-move - (ww::on-mousemotion (target x y xrel yrel state) - (with-slots (pen-down-p) target - (when pen-down-p - (ww:with-canvas target - (ww:with-pen (:position pen-down-p) - (ww:stroke-to x y))) - (setf (car pen-down-p) x (cadr pen-down-p) y) - (ww:blit target))))) + (ww::on-mousemotion (target x y) + (when (pen-down-pos target) + (ecase (mode target) + (:draw (draw target x y)) + (:drag (drag target x y)))))) (defmethod initialize-instance :after ((ob pwcanvas) &key) - (ww:add-handler ob #'canvas-mousebutton-down) + (ww:add-handler ob #'keyboard-commands) + (ww:add-handler ob #'change-mode-start) + (ww:add-handler ob #'change-mode-stop) + (ww:add-handler ob #'zoom) (ww:add-handler ob #'canvas-mousebutton-up) + (ww:add-handler ob #'canvas-mousebutton-down) (ww:add-handler ob #'canvas-mouse-move)) (defmethod ww:boot ((app pixel-whomp)) |