[add] canvas language and [example]

4 files changed, 146 insertions, 1 deletions

diff --git a/src/canvas-language.lisp b/src/canvas-language.lisp
new file mode 100644
index 0000000..24a3394
--- /dev/null
+++ b/src/canvas-language.lisp
@@ -0,0 +1,141 @@
+;;;; canvas-language.lisp  -- a drawing api for canvas instances
+
+(in-package #:wheelwork)
+
+(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))
+
+
+
+(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))
+
+(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-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)
+         (< -1 y pixel-height))))
+
+(defun rel-to-current-pos (path)
+  (destructuring-bind (cx cy) *current-pen-position* 
+    (loop for (x y) in path collect (list (+ cx x) (+ cy y)))))
+
+(defun move-to (x y)
+  (setf *current-pen-position* (list x y)))
+
+(defun move-rel (dx dy)
+  (setf *current-pen-position*
+        (mapcar #'+ *current-pen-position* (list dx dy))))
+
+(defun apply-pen-at (x y)
+  (let ((w
+          (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*) 
+      (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)
+            (setf r cr g cg b cb a ca)))))))
+
+(defun stroke-to (ex ey)
+  (destructuring-bind (sx sy) *current-pen-position* 
+    (with-grid-line (x y) (sx sy) (ex ey)
+      (apply-pen-at x y)))
+  (setf *current-pen-position* (list ex ey)))
+
+(defun stroke-rel (dx dy)
+  (apply #'stroke-to (mapcar #'+ *current-pen-position* (list dx dy))))
+
+(defun stroke-path (path)
+  (with-grid-path (x y) (path) (apply-pen-at x y))
+  (setf *current-pen-position* (copy-list (first (last path)))))
+
+(defun stroke-rel-path (path)
+  (stroke-path
+   (cons *current-pen-position*
+         (rel-to-current-pos path))))
+
+(defun fill-path (path)
+  (let ((*current-pen-width* 1)) 
+    (with-grid-path (x y) (path :interiorp t)
+      (apply-pen-at x y))))
+
+(defun fill-rel-path (path)
+  (fill-path
+   (cons *current-pen-position*
+         (rel-to-current-pos path))))
+
+(defun stroke-rect (left bottom right top)
+  (stroke-path (list (list left bottom)
+                     (list left top)
+                     (list right top)
+                     (list right bottom)
+                     (list left bottom))))
+
+(defun stroke-rel-rect (dx dy)
+  (destructuring-bind (sx sy) *current-pen-position*
+    (let ((left
+            (if (plusp dx) sx (+ sx dx)))
+          (right
+            (if (plusp dx) (+ sx dx) sx))
+          (bottom
+            (if (plusp dy) sy (+ sx sy)))
+          (top
+            (if (plusp dy) (+ sy dy) sy)))
+      (stroke-rect left right bottom top))))
+
+(defun fill-rect (left bottom right top)
+  (let ((*current-pen-width* 1))
+    (with-grid-rect (x y) (left bottom right top)
+      (apply-pen-at x y)))
+  (setf *current-pen-position* (list left bottom)))
+
+(defun fill-rel-rect (dx dy)
+  (destructuring-bind (sx sy) *current-pen-position*
+    (let ((left
+            (if (plusp dx) sx (+ sx dx)))
+          (right
+            (if (plusp dx) (+ sx dx) sx))
+          (bottom
+            (if (plusp dy) sy (+ sx sy)))
+          (top
+            (if (plusp dy) (+ sy dy) sy)))
+      (fill-rect left right bottom 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)))
+
+(defun stroke-rel-bezier (rel-control-points &optional (curve-samples 10))
+  (stroke-bezier (cons *current-pen-position*
+                       (rel-to-current-pos rel-control-points))
+                 curve-samples))
diff --git a/src/grid-geometry.lisp b/src/grid-geometry.lisp
index c046032..5fdfdd8 100644
--- a/src/grid-geometry.lisp
+++ b/src/grid-geometry.lisp
@@ -121,3 +121,4 @@ Evaluates the BODY with X Y bound to a point on the bezier curve.
        (loop for ,a from 0.0 to 1.0 by ,step
              for (,x ,y) = (mapcar #'round (funcall ,fn ,a))
              do ,@body))))
+
diff --git a/src/utils.lisp b/src/utils.lisp
index f3dba06..4ace1b8 100644
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -150,3 +150,7 @@ the path."
             sum (* coeff y) into by
             finally (return (list bx by))))))
 
+(defun clamp (lo val hi)
+  "Returns VAL if (< LO VAL HI), otherwise returns LO or HI depending
+on which boundary VAL is outside of."
+  (max lo (min val hi)))
diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp
index 31efe14..db49e03 100644
--- a/src/wheelwork.lisp
+++ b/src/wheelwork.lisp
@@ -36,7 +36,6 @@
 (defun stop ()
   (sdl2:push-event :quit))
 
-
 (defun refocus-on (target &optional (app *application*))
   "Sets focus of application to TARGET. This works whether or not
 TARGET is FOCUSABLEP"