diff options
| -rw-r--r-- | examples/11-canvas-geometry.lisp | 48 | ||||
| -rw-r--r-- | src/grid-geometry.lisp | 103 |
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))))))) |