1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
;;; grid-geometry.lisp
(in-package :wheelwork )
(defmacro with-grid-line
((x y) (start-x start-y) (end-x end-y) &body body)
"Execute BODY for X and Y assigned to integer values in a line
connecting the integer point START-X , START-Y and END-X, END-Y. "
(with-gensyms (sx sy ex ey distance step progress xdiff ydiff)
`(loop
with ,sx = ,start-x
with ,sy = ,start-y
with ,ex = ,end-x
with ,ey = ,end-y
with ,xdiff = (- ,ex ,sx)
with ,ydiff = (- ,ey, sy)
with ,distance = (max (abs ,xdiff) (abs ,ydiff))
for ,step from 0 to ,distance
for ,progress = (if (zerop ,distance) 0.0 (/ ,step ,distance))
for ,x = (round (+ ,start-x (* ,progress ,xdiff)))
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
top right corners of the bounding box for POLY "
(loop for (x y) in poly
minimizing x into x-min
maximizing x into x-max
minimizing y into y-min
maximizing y into y-max
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)))))))
(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)
(with-gensyms (rad sx sy)
(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))))))
|
