diff options
| -rw-r--r-- | examples/13-menus.lisp | 2 | ||||
| -rw-r--r-- | examples/14-canvas-paint.lisp | 51 | ||||
| -rw-r--r-- | src/canvas-language.lisp | 23 | ||||
| -rw-r--r-- | src/interactive/canvas.lisp | 5 | ||||
| -rw-r--r-- | wheelwork-examples.asd | 3 |
5 files changed, 69 insertions, 15 deletions
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"))) |