[add] path drwing and filling to canvas

2 files changed, 99 insertions, 52 deletions

diff --git a/examples/11-canvas-geometry.lisp b/examples/11-canvas-geometry.lisp
index 1147ed9..8565eb3 100644
--- a/examples/11-canvas-geometry.lisp
+++ b/examples/11-canvas-geometry.lisp
@@ -8,11 +8,16 @@
 
 (defclass geo-demo (ww:application) ())
 
+(ww:defhandler quit
+    (ww::on-keydown (app scancode)
+      (when (eql :scancode-q scancode)
+        (ww::stop))))
+
 (defmethod ww:boot ((app geo-demo))
   (let ((canvas
           (make-instance 'ww:canvas
-                         :pixel-width 500
-                         :pixel-height 500)))
+                         :pixel-width 200
+                         :pixel-height 200)))
     ;; stretch canvas over the whole app
     (setf (ww:width canvas) (ww::application-width app)
           (ww:height canvas) (ww::application-height app))
@@ -21,12 +26,45 @@
     (ww:add-unit app canvas)
 
     ;; draw a circle
-    (ww::with-grid-circle (x y) (50 50 30)
+    (ww::with-grid-circle (x y) (150 50 30 :interiorp t)
       (ww::with-pixel (r g b a) (ww::pixel canvas x y)
         (setf r (mod (* x y) 255)
               g x
               b y)))
-    
 
+    ;; draw a bunch of circles
+    (loop
+      for cx from 0 to 50 by 5 
+      for cy from 0 to 50 by 5 do
+        (ww::with-grid-circle (x y) ((+ 100 cx) (+ 100 cy) 10)
+          (ww::with-pixel (r g b a) (ww::pixel canvas x y)
+            (setf r (mod (* x y) 256)
+                  g (mod (* x x) 256)
+                  b (mod (* y x) 256)))))
+
+    ;; draw a random pentagonal thing
+    (let ((path
+            (loop repeat 7
+                  collect (list (+ 10 (random 80))
+                                (+ 10 (random 80))))))
+      (ww::with-grid-path (x y) (path :autoclosep t :interiorp t)
+        (ww::with-pixel (r g b a) (ww::pixel canvas x y)
+          (setf r (mod y 256)
+                g (mod x 256)
+                b (mod (* x y) 256)))))
+    
     ;; blit the canvas
-    (ww::blit canvas)))
+    (ww::blit canvas)
+
+    ;; quit handler
+    (ww:add-handler app #'quit)
+    (ww:add-handler canvas #'quit)))
+
+(defun start ()
+  (ww::start
+   (make-instance
+    'geo-demo
+    :fps 10
+    :width 500
+    :height 500
+    :title "Pixels Geometry")))
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)))))))