diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/canvas-language.lisp | 141 | ||||
| -rw-r--r-- | src/grid-geometry.lisp | 1 | ||||
| -rw-r--r-- | src/utils.lisp | 4 | ||||
| -rw-r--r-- | src/wheelwork.lisp | 1 |
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" |