From 24b0c51a3b51c52dbba855787170107a6a7e47fb Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Tue, 19 Jul 2022 10:44:16 -0500 Subject: [add] canvas language and [example] --- examples/12-canvas-drawing-language.lisp | 64 ++++++++++++++ src/canvas-language.lisp | 141 +++++++++++++++++++++++++++++++ src/grid-geometry.lisp | 1 + src/utils.lisp | 4 + src/wheelwork.lisp | 1 - 5 files changed, 210 insertions(+), 1 deletion(-) create mode 100644 examples/12-canvas-drawing-language.lisp create mode 100644 src/canvas-language.lisp 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" -- cgit v1.2.3