diff options
| -rw-r--r-- | examples/11-canvas-geometry.lisp | 32 | ||||
| -rw-r--r-- | src/grid-geometry.lisp | 70 | ||||
| -rw-r--r-- | src/interactive/canvas.lisp | 1 | ||||
| -rw-r--r-- | src/utils.lisp | 27 | ||||
| -rw-r--r-- | wheelwork-examples.asd | 3 | ||||
| -rw-r--r-- | wheelwork.asd | 1 |
6 files changed, 109 insertions, 25 deletions
diff --git a/examples/11-canvas-geometry.lisp b/examples/11-canvas-geometry.lisp new file mode 100644 index 0000000..1147ed9 --- /dev/null +++ b/examples/11-canvas-geometry.lisp @@ -0,0 +1,32 @@ +;;;; examples/11-canvas-geometry.lisp + +(defpackage #:ww.examples/11 + (:use #:cl) + (:export #:start)) + +(in-package :ww.examples/11) + +(defclass geo-demo (ww:application) ()) + +(defmethod ww:boot ((app geo-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) + + ;; draw a circle + (ww::with-grid-circle (x y) (50 50 30) + (ww::with-pixel (r g b a) (ww::pixel canvas x y) + (setf r (mod (* x y) 255) + g x + b y))) + + + ;; blit the canvas + (ww::blit canvas))) diff --git a/src/grid-geometry.lisp b/src/grid-geometry.lisp new file mode 100644 index 0000000..cef69f8 --- /dev/null +++ b/src/grid-geometry.lisp @@ -0,0 +1,70 @@ +;;; grid-geometry.lisp + +(in-package :wheelwork ) + +(defmacro with-grid-line + ((x y) (start-x start-y) (end-x end-y) &body body) + "Execute BODY for X and Y assigned to integer values in a line +connecting the integer point START-X , START-Y and END-X, END-Y. " + (with-gensyms (sx sy ex ey distance step progress xdiff ydiff) + `(loop + with ,sx = ,start-x + with ,sy = ,start-y + with ,ex = ,end-x + with ,ey = ,end-y + with ,xdiff = (- ,ex ,sx) + with ,ydiff = (- ,ey, sy) + with ,distance = (max (abs ,xdiff) (abs ,ydiff)) + for ,step from 0 to ,distance + for ,progress = (if (zerop ,distance) 0.0 (/ ,step ,distance)) + for ,x = (round (+ ,start-x (* ,progress ,xdiff))) + for ,y = (round (+ ,start-y (* ,progress ,ydiff))) + do (progn ,@body)))) + +(defmacro with-grid-path + ((x y) (path &key autoclosep interiorp) &body body) + (with-gensyms (points x1 y1 x2 y2 more) + (let ((autoclose-block + (when autoclosep + `(destructuring-bind (,x2 ,y2) (first ,points) + (with-grid-line (,x2 ,y2) (,x1 ,y1) ,@body))))) + `(let ((,points ,path)) + (loop + for ((,x1 ,y) (,x2 ,y2) . ,more) on ,points + while ,x2 do + (with-grid-line (,x ,y) (,x1 ,y1) (,x2 ,y2) ,@body) + finally (progn ,autoclose-block)))))) + +(defun grid-bbox-for (poly) + "POLY is a list of pairs of xy coordinates. Return a pair of +pairs, ((min-x min-y) (max-x max-y)), representing the bottom left and +top right corners of the bounding box for POLY " + (loop for (x y) in poly + minimizing x into x-min + maximizing x into x-max + minimizing y into y-min + maximizing y into y-max + finally (return (list (list x-min y-min) + (list x-max y-max))))) + +(defmacro with-grid-poly-interior + ((x y) perimeter &body body) + "PERMIETER is expected to evaluate to a list of contiguous points, +representing the permimeter a polygon in 2d space. Execute BODY for +each point interior to this polygon." + (with-gensyms (points bottom left top right) + `(let ((,points ,permieter)) + (destructuring-bind ((,left ,bottom) (,right ,top)) (grid-bbox-for ,points) + (loop ) + ))) + ) + +(defmacro with-grid-circle + ((x y) (cx cy radius &key interiorp) &body body) + (with-gensyms (rad sx sy) + (let ((comparator + (if interiorp '>= '=))) + `(let ((,sx ,cx) (,sy ,cy) (,rad ,radius)) + (with-grid-rect (,x ,y) ((- ,sx ,rad) (- ,sy ,rad) (+ ,sx ,rad) (+ ,sy ,rad)) + (when (,comparator ,rad (round (euclidean-dist ,x ,y ,sx ,sy))) + ,@body)))))) diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp index e8bdc39..7f24d89 100644 --- a/src/interactive/canvas.lisp +++ b/src/interactive/canvas.lisp @@ -92,7 +92,6 @@ e.g., drawing a line in a particular color." (with-grid-line (,x ,y) (,start-x ,start-y) (,end-x ,end-y) (with-pixel (,r ,g ,b ,a) (pixel ,pxs ,x ,y) ,@body))))) - (defvar *canvas-shader-program* nil) (defvar *canvas-render-vao* nil) (defvar *canvas-count* 0) diff --git a/src/utils.lisp b/src/utils.lisp index 4037b7a..7b68e3d 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -41,7 +41,6 @@ and B intersects the linesegment between C and D, NIL otherwise." while b2 thereis (segments-intersect-p a1 a2 b1 b2)))) - (defun closed-path-p (path) (equalp (first path) (first (last path)))) @@ -63,8 +62,6 @@ and B intersects the linesegment between C and D, NIL otherwise." finally (return (oddp intersection-count))))) - - (defun path-encloses-path-p (path-a path-b) "T if path-b is totally contained in path-a and does not intersect path-a" (assert (closed-path-p path-a) () "Enclosing path must be a closed path.") @@ -115,23 +112,7 @@ the path." `(let ((,value ,value-form)) (setf ,@clauses)))) - -(defmacro with-grid-line - ((x y) (start-x start-y) (end-x end-y) &body body) - "Execute BODY for X and Y assigned to integer values in a line -connecting the integer point START-X , START-Y and END-X, END-Y. " - (with-gensyms (sx sy ex ey distance step progress xdiff ydiff) - `(loop - with ,sx = ,start-x - with ,sy = ,start-y - with ,ex = ,end-x - with ,ey = ,end-y - with ,xdiff = (- ,ex ,sx) - with ,ydiff = (- ,ey, sy) - with ,distance = (max (abs ,xdiff) (abs ,ydiff)) - for ,step from 0 to ,distance - for ,progress = (if (zerop ,distance) 0.0 (/ ,step ,distance)) - for ,x = (round (+ ,start-x (* ,progress ,xdiff))) - for ,y = (round (+ ,start-y (* ,progress ,ydiff))) - do (progn ,@body)))) - +(defun euclidean-dist (x1 y1 x2 y2) + (let ((dx (- x2 x1)) + (dy (- y2 y1))) + (sqrt (+ (* dx dx) (* dy dy))))) diff --git a/wheelwork-examples.asd b/wheelwork-examples.asd index 862358c..ca6e328 100644 --- a/wheelwork-examples.asd +++ b/wheelwork-examples.asd @@ -15,4 +15,5 @@ (:file "07-renderarea") (:file "08-pong") (:file "09-ghoulspree") - (:file "10-canvas-sneks"))) + (:file "10-canvas-sneks") + (:file "11-canvas-geometry"))) diff --git a/wheelwork.asd b/wheelwork.asd index 06fa686..086c1c7 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -19,6 +19,7 @@ :components ((:file "package") (:file "protocol") (:file "utils") + (:file "grid-geometry") (:module "gl" :components ((:file "util") (:file "texture") |