aboutsummaryrefslogtreecommitdiffhomepage
path: root/examples
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-07-28 11:04:45 -0500
committerColin Okay <colin@cicadas.surf>2022-07-28 11:04:45 -0500
commit58f667aa9106a1c05d2bb94c8d5ef5d6cc674d79 (patch)
tree270baac6c92a70a9fa84e8bfc0c3996a46cbf98f /examples
parentfdfee6053fb8430566eb7a9960b77cf28826aa01 (diff)
[example] hacking
Diffstat (limited to 'examples')
-rw-r--r--examples/14-canvas-paint.lisp108
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))