diff options
| -rw-r--r-- | src/grid-geometry.lisp | 48 | ||||
| -rw-r--r-- | src/wheelwork.lisp | 3 |
2 files changed, 38 insertions, 13 deletions
diff --git a/src/grid-geometry.lisp b/src/grid-geometry.lisp index cef69f8..bddde38 100644 --- a/src/grid-geometry.lisp +++ b/src/grid-geometry.lisp @@ -23,17 +23,31 @@ connecting the integer point START-X , START-Y and END-X, END-Y. " (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)) + (with-gensyms (points x1 y1 x2 y2 more perimeter) + (let* ((perimeter-acc-clause + (when (and autoclosep interiorp) + `(pushnew (list ,x ,y) ,perimeter :test #'equalp))) + (autoclose-clause + (when autoclosep + `(destructuring-bind (,x2 ,y2) (first ,points) + (with-grid-line (,x2 ,y2) (,x1 ,y1) + ,perimeter-acc-clause + ,@body)))) + (autofill-clause + (when (and autoclosep interiorp) + `(with-grid-poly-interior (,x ,y) ,perimeter ,@body)))) + `(let ((,points ,path) + (,perimeter nil)) (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)))))) + (with-grid-line (,x ,y) (,x1 ,y1) (,x2 ,y2) + (progn + ,perimeter-acc-clause + ,@body)) + finally (progn + ,autoclose-clause + ,autofill-clause)))))) (defun grid-bbox-for (poly) "POLY is a list of pairs of xy coordinates. Return a pair of @@ -52,12 +66,20 @@ top right corners of the bounding box for POLY " "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)) + (with-gensyms (points bottom left top right inside) + `(let ((,points ,perimeter) + (,inside nil)) (destructuring-bind ((,left ,bottom) (,right ,top)) (grid-bbox-for ,points) - (loop ) - ))) - ) + (loop for ,y from ,bottom to ,top do + (loop for ,x from ,left to ,right + when (member (list ,x ,y) ,points :test #'equalp) + do (setf ,inside (not ,inside)) + when ,inside + do (progn ,@body))))))) + +(defmacro with-grid-rect ((x y) (left bottom right top) &body body) + `(loop for ,x from ,left to ,right do + (loop for ,y from ,bottom to ,top do ,@body ))) (defmacro with-grid-circle ((x y) (cx cy radius &key interiorp) &body body) diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp index 8b1e534..41157e6 100644 --- a/src/wheelwork.lisp +++ b/src/wheelwork.lisp @@ -33,6 +33,9 @@ (shutdown app)) (cleanup app))))))) +(defun stop () + (sdl2:push-event :quit)) + (defun refocus-on (target &optional (app *application*)) "Sets focus of application to TARGET. This works whether or not |