diff options
| -rw-r--r-- | src/canvas-language.lisp | 68 |
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* |