diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/grid-geometry.lisp | 103 |
1 files changed, 56 insertions, 47 deletions
diff --git a/src/grid-geometry.lisp b/src/grid-geometry.lisp index bddde38..eac3d5a 100644 --- a/src/grid-geometry.lisp +++ b/src/grid-geometry.lisp @@ -21,34 +21,6 @@ connecting the integer point START-X , START-Y and END-X, END-Y. " 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 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) - (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 pairs, ((min-x min-y) (max-x max-y)), representing the bottom left and @@ -61,25 +33,61 @@ top right corners of the bounding box for POLY " 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 inside) - `(let ((,points ,perimeter) - (,inside nil)) - (destructuring-bind ((,left ,bottom) (,right ,top)) (grid-bbox-for ,points) - (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))))))) +(defun grid-counterclockwisep (a b c) + (> (* (- (first b) (first a)) + (- (second c) (second a))) + (* (- (second b) (second a)) + (- (first c) (first a))))) + +(defun grid-segments-intersect-p (a b c d) + (or (equalp a c) (equalp a d) (equalp b c) (equalp b d) + (and (not (eq (grid-counterclockwisep a c d) (grid-counterclockwisep b c d))) + (not (eq (grid-counterclockwisep a b c) (grid-counterclockwisep a b d)))))) + +(defun grid-poly-contains-p (poly x y) + (let ((pt + (list x y)) + (corner + (list -1 x))) + (loop for (p1 p2 . more) on poly + while p2 + when (grid-segments-intersect-p p1 p2 pt corner) + count 1 into intersection-count + finally + (progn + (when (grid-segments-intersect-p p1 (first poly) pt corner) + (incf intersection-count)) + (return (oddp intersection-count)))))) + +(defmacro with-grid-path + ((x y) (path &key autoclosep interiorp) &body body) + "Interiorp assumes autoclosep." + (with-gensyms (points x1 y1 x2 y2 more) + (let* ((autoclose-clause + (when autoclosep + `(destructuring-bind (,x2 ,y2) (first ,points) + (with-grid-line (,x ,y) (,x2 ,y2) (,x1 ,y1) + ,@body)))) + (interior-clause + (when (and autoclosep interiorp) + `(destructuring-bind ((,x1 ,y1) (,x2 ,y2)) (grid-bbox-for ,points) + (loop for ,x from ,x1 to ,x2 do + (loop for ,y from ,y1 to ,y2 + when (grid-poly-contains-p ,points ,x ,y) + do ,@body)))))) + `(let ((,points ,path)) + (loop + for ((,x1 ,y1) (,x2 ,y2) . ,more) on ,points + while ,x2 do + (with-grid-line (,x ,y) (,x1 ,y1) (,x2 ,y2) + ,@body) + finally (progn + ,autoclose-clause + ,interior-clause)))))) (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 ))) + (loop for ,y from ,bottom to ,top do ,@body ))) (defmacro with-grid-circle ((x y) (cx cy radius &key interiorp) &body body) @@ -87,6 +95,7 @@ each point interior to this polygon." (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)))))) + (loop for ,x from (- ,sx ,rad) to (+ ,sx ,rad) do + (loop for ,y from (- ,sy ,rad) to (+ ,sy ,rad) do + (when (,comparator ,rad (round (euclidean-dist ,x ,y ,sx ,sy))) + ,@body))))))) |