[add] path drwing and filling to canvas

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)))))))