[fix] bug in stroke and fill rect; [refactor] pen color state

1 files changed, 43 insertions, 25 deletions

diff --git a/src/canvas-language.lisp b/src/canvas-language.lisp
index 6583fc8..7ea72a4 100644
--- a/src/canvas-language.lisp
+++ b/src/canvas-language.lisp
@@ -5,42 +5,59 @@
 (defvar *current-canvas* nil
   "Bound by with-canvas")
 (defvar *current-pen-color* '(0 0 0 255))
-(defvar *current-pen-color-function* nil)
 
 (defvar *current-pen-width* 1)
 
 (defvar *current-pen-position* '(0 0))
 
+(defvar *saved-state* nil)
+
+(defmacro with-canvas-state (&body body)
+  `(let 
+       ((*saved-state*
+          (list *current-pen-width*
+                *current-pen-position*
+                *current-pen-color*)))
+     ,@body))
+
+(defmacro with-pen-color (list-or-fn &body body)
+  `(let ((*current-pen-color* nil))
+     (canvas-pen-color ,list-or-fn)
+     ,@body))
 
 
 (defmacro with-canvas (canvas &body body)
   `(let ((*current-canvas* ,canvas)
          (*current-pen-width* 1)
          (*current-pen-position* (list 0 0))
-         (*current-pen-color* (list 0 0 0 255))
-         (*current-pen-color-function* nil))
-     ,@body))
+         (*current-pen-color* (list 0 0 0 255)))
+     (with-canvas-state 
+       ,@body)))
+
+
+(defun restore-canvas-state ()
+  (destructuring-bind (pw pp pc) *saved-state*
+    (setf *current-pen-width* pw
+          *current-pen-position* pp
+          *current-pen-color* pc)))
+
 
 (defun colfix (c)
   (round (clamp 0 c 255)))
 
-(defun canvas-pen-color (r g b a)
-  (setf *current-pen-color* (mapcar #'colfix (list r g b a))))
-
-(defun canvas-pen-color-function (&optional fn)
-  (setf *current-pen-color-function*
-        (when fn
-         (lambda (x y)
-           (mapcar #'colfix (funcall fn x y))))))
+(defun canvas-pen-color (&optional newpen)
+  (setf *current-pen-color* 
+        (etypecase newpen
+          (null nil)
+          ((or symbol function)
+           (lambda (x y)
+             (mapcar #'colfix (funcall newpen x y))))
+          (list
+           (mapcar #'colfix newpen)))))
 
 (defun canvas-pen-width (n)
   (setf *current-pen-width* (round n)))
 
-(defmacro with-pen-color ((r g b a) &body body)
-  `(let ((ww::*current-pen-color* nil))
-     (canvas-pen-color ,r ,g ,b ,a)
-     ,@body))
-
 (defun can-fill-canvas-at-p (x y)
   (with-slots (pixel-width pixel-height) *current-canvas*
     (and (< -1 x pixel-width)
@@ -62,9 +79,10 @@
           (max 0 (floor (* 0.5 *current-pen-width*)))))
     (destructuring-bind
         (cr cg cb ca)
-        (if *current-pen-color-function*
-            (funcall *current-pen-color-function* x y)
-            *current-pen-color*) 
+        (etypecase *current-pen-color*
+          (null (list 0 0 0 255))
+          (list *current-pen-color*)
+          (function (funcall *current-pen-color* x y))) 
       (with-grid-rect (rx ry) ((- x w) (- y w) (+ x w) (+ y w))
         (when (can-fill-canvas-at-p rx ry) 
           (with-pixel (r g b a) (pixel *current-canvas* rx ry)
@@ -112,10 +130,10 @@
           (right
             (if (plusp dx) (+ sx dx) sx))
           (bottom
-            (if (plusp dy) sy (+ sx sy)))
+            (if (plusp dy) sy (+ sy dy)))
           (top
             (if (plusp dy) (+ sy dy) sy)))
-      (stroke-rect left right bottom top))))
+      (stroke-rect left bottom right top))))
 
 (defun fill-rect (left bottom right top)
   (let ((*current-pen-width* 1))
@@ -130,16 +148,16 @@
           (right
             (if (plusp dx) (+ sx dx) sx))
           (bottom
-            (if (plusp dy) sy (+ sx sy)))
+            (if (plusp dy) sy (+ sy dy)))
           (top
             (if (plusp dy) (+ sy dy) sy)))
-      (fill-rect left right bottom top))))
+      (fill-rect left bottom right top))))
 
 (defun stroke-bezier (control-pts &optional (curve-samples 10))
   (let (path)
     (with-grid-bezier (x y) (control-pts :count curve-samples)
       (push (list x y) path))
-    (stroke-path path)))
+    (stroke-path (reverse path))))
 
 (defun stroke-rel-bezier (rel-control-points &optional (curve-samples 10))
   (stroke-bezier (cons *current-pen-position*