From 58f667aa9106a1c05d2bb94c8d5ef5d6cc674d79 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Thu, 28 Jul 2022 11:04:45 -0500
Subject: [example] hacking

---
 examples/14-canvas-paint.lisp | 108 ++++++++++++++++++++++++++++++++++++------
 1 file 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))
-- 
cgit v1.2.3