From b582b2d4273efa61b3c3ea2bb9e77a74e0606670 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Thu, 28 Jul 2022 12:13:47 -0500
Subject: [example] hacking to improve zoom

---
 examples/14-canvas-paint.lisp | 33 +++++++++++++++++++++++++++------
 1 file changed, 27 insertions(+), 6 deletions(-)

(limited to 'examples')

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 ()
-- 
cgit v1.2.3