From fdfee6053fb8430566eb7a9960b77cf28826aa01 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Thu, 28 Jul 2022 09:38:35 -0500
Subject: [add] canvas-paint example; [refactor] with-current-pen

---
 examples/13-menus.lisp        |  2 +-
 examples/14-canvas-paint.lisp | 51 +++++++++++++++++++++++++++++++++++++++++++
 src/canvas-language.lisp      | 23 +++++++++----------
 src/interactive/canvas.lisp   |  5 +++--
 wheelwork-examples.asd        |  3 ++-
 5 files changed, 69 insertions(+), 15 deletions(-)
 create mode 100644 examples/14-canvas-paint.lisp

diff --git a/examples/13-menus.lisp b/examples/13-menus.lisp
index 2c797f3..07094c8 100644
--- a/examples/13-menus.lisp
+++ b/examples/13-menus.lisp
@@ -1,4 +1,4 @@
-;;;; menus.lisp
+;;;; 13-menus.lisp
 
 (defpackage #:ww.examples/13
   (:use #:cl)
diff --git a/examples/14-canvas-paint.lisp b/examples/14-canvas-paint.lisp
new file mode 100644
index 0000000..bca6a13
--- /dev/null
+++ b/examples/14-canvas-paint.lisp
@@ -0,0 +1,51 @@
+;;;; 14-canvas-paint.lisp
+
+(defpackage #:ww.examples/14
+  (:use #:cl)
+  (:export #:start))
+
+(in-package #:ww.examples/14)
+
+(defclass pixel-whomp (ww:application) ())
+
+(defclass pwcanvas (ww:canvas)
+  ((pen-down-p :accessor pen-down-p :initform nil)))
+
+
+(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)))))
+
+(ww::defhandler canvas-mousebutton-up
+    (ww::on-mouseup (target)
+      (setf (pen-down-p target) nil)))
+
+(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)))))
+
+(defmethod initialize-instance :after ((ob pwcanvas) &key)
+  (ww:add-handler ob #'canvas-mousebutton-down)
+  (ww:add-handler ob #'canvas-mousebutton-up)
+  (ww:add-handler ob #'canvas-mouse-move))
+
+(defmethod ww:boot ((app pixel-whomp))
+  (let ((canvas
+          (make-instance 'pwcanvas
+                         :pixel-width 800
+                         :pixel-height 800)))
+    (ww:add-unit canvas)))
+
+(defun start ()
+  (ww:start
+   (make-instance 'pixel-whomp)
+   :x 2350))
diff --git a/src/canvas-language.lisp b/src/canvas-language.lisp
index 8188e53..b90e22d 100644
--- a/src/canvas-language.lisp
+++ b/src/canvas-language.lisp
@@ -24,17 +24,18 @@
   "Like WITH-CURRENT-PEN, but lets you set the state of the pen
   EXECUTION BODY.  After BODY executes, the state is restored to
   whatever it was before WITH-PEN-STATE was evaluated."
-  `(let ((*current-pen-position* ,(if position nil '*current-pen-position*))
-         (*current-pen-color* ,(if color-supplied-p nil '*current-pen-color*))
-         (*current-pen-width* ,(if width nil '*current-pen-width*)))
-     ,(when position
-        `(move-to ,@position))
-     ,(when color-supplied-p
-        `(canvas-pen-color ,color))
-     ,(when width
-        `(canvas-pen-width ,width))
-     (with-current-pen
-       ,@body)))
+  (with-gensyms (newpos) 
+    `(let ((*current-pen-position* ,(if position nil '*current-pen-position*))
+           (*current-pen-color* ,(if color-supplied-p nil '*current-pen-color*))
+           (*current-pen-width* ,(if width nil '*current-pen-width*)))
+       ,(when position
+          `(let ((,newpos ,position))  (apply 'move-pen-to ,newpos)))
+       ,(when color-supplied-p
+          `(canvas-pen-color ,color))
+       ,(when width
+          `(canvas-pen-width ,width))
+       (with-current-pen
+         ,@body))))
 
 (defmacro with-canvas (canvas &body body)
   "Perform drawing commands in BODY using the value of CANVAS as the
diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp
index d870ae8..977e3ec 100644
--- a/src/interactive/canvas.lisp
+++ b/src/interactive/canvas.lisp
@@ -3,7 +3,7 @@
 (in-package #:wheelwork)
 
 (defclass/std pixels ()
-  ((pixel-width pixel-height  :std (error "pixel-width and pixel-height are required"))
+  ((pixel-width pixel-height :std (error "pixel-width and pixel-height are required"))
    (data :a :with :doc "Array of RGBA data representing an image of pixel-width X pixel-height")))
 
 (defmethod initialize-instance :after ((pixels pixels) &key)
@@ -23,7 +23,8 @@
 
      I.E. If you are are wanting to manipulate more than one pixel at
      a time, you should get those pixels with USE-CACHED set to NIL."
-    (with-slots (pixel-width pixel-height data) pixels 
+    (let ((pixel-width (pixel-width pixels))
+          (data (pixels-data pixels))) 
       (cond
         ((and use-cached cached-pixel)
          (adjust-array cached-pixel 4
diff --git a/wheelwork-examples.asd b/wheelwork-examples.asd
index 81fb76d..3243831 100644
--- a/wheelwork-examples.asd
+++ b/wheelwork-examples.asd
@@ -18,4 +18,5 @@
                (:file "10-canvas-sneks")
                (:file "11-canvas-geometry")
                (:file "12-canvas-drawing-language")
-               (:file "13-menus")))
+               (:file "13-menus")
+               (:file "14-canvas-paint")))
-- 
cgit v1.2.3