aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-07-19 10:44:16 -0500
committerColin Okay <colin@cicadas.surf>2022-07-19 10:44:16 -0500
commit24b0c51a3b51c52dbba855787170107a6a7e47fb (patch)
tree6e7da9cda477b345702f0ef686d3b6fd6495852a
parentba248e490e1ab67e124b02e765e0ee3ec7a3dd45 (diff)
[add] canvas language and [example]
-rw-r--r--examples/12-canvas-drawing-language.lisp64
-rw-r--r--src/canvas-language.lisp141
-rw-r--r--src/grid-geometry.lisp1
-rw-r--r--src/utils.lisp4
-rw-r--r--src/wheelwork.lisp1
5 files changed, 210 insertions, 1 deletions
diff --git a/examples/12-canvas-drawing-language.lisp b/examples/12-canvas-drawing-language.lisp
new file mode 100644
index 0000000..526ec2d
--- /dev/null
+++ b/examples/12-canvas-drawing-language.lisp
@@ -0,0 +1,64 @@
+;;;; examples/13-canvas-drawing-language.lisp
+
+(defpackage #:ww.examples/12
+ (:use #:cl)
+ (:export #:start))
+
+(in-package :ww.examples/12)
+
+(defclass canvas-lang-demo (ww:application) ())
+
+(ww:defhandler quit
+ (ww::on-keydown (app scancode)
+ (when (eql :scancode-q scancode)
+ (ww::stop))))
+
+(ww:defhandler clear-and-draw
+ (ww::on-perframe (canvas time)
+ (ww::clear-canvas canvas :r 255 :g 255 :b 255)
+ (draw-stuff canvas time)
+ (ww::blit canvas)))
+
+(defun triangle-at (x y)
+ (ww::move-to x y)
+ (ww::stroke-rel 150 0)
+ (ww::stroke-rel 0 130)
+ (ww::stroke-rel -150 -130))
+
+(defun filled-triangle-at (x y)
+ (ww::move-to x y)
+ (ww::fill-rel-path
+ '((-10 100)
+ (10 -30))))
+
+(defun draw-stuff (canvas time)
+ (declare (ignorable time))
+ (ww::with-canvas canvas
+ (triangle-at 100 100)
+ (filled-triangle-at 200 200)))
+
+(defmethod ww:boot ((app canvas-lang-demo ))
+ (let ((canvas
+ (make-instance 'ww:canvas
+ :pixel-width 500
+ :pixel-height 500)))
+ ;; stretch canvas over the whole app
+ (setf (ww:width canvas) (ww::application-width app)
+ (ww:height canvas) (ww::application-height app))
+
+ ;; add it to the display tree
+ (ww:add-unit app canvas)
+
+ ;; handlers
+ (ww::add-handler canvas #'clear-and-draw)
+ (ww:add-handler app #'quit)
+ (ww:add-handler canvas #'quit)))
+
+(defun start (&optional (side 500))
+ (ww::start
+ (make-instance
+ 'canvas-lang-demo
+ :fps 10
+ :width side
+ :height side
+ :title "Canvas demo")))
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"