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
|
;;; 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)
(let ((autoclose-block
(when autoclosep
`(destructuring-bind (,x2 ,y2) (first ,points)
(with-grid-line (,x2 ,y2) (,x1 ,y1) ,@body)))))
`(let ((,points ,path))
(loop
for ((,x1 ,y) (,x2 ,y2) . ,more) on ,points
while ,x2 do
(with-grid-line (,x ,y) (,x1 ,y1) (,x2 ,y2) ,@body)
finally (progn ,autoclose-block))))))
(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)
`(let ((,points ,permieter))
(destructuring-bind ((,left ,bottom) (,right ,top)) (grid-bbox-for ,points)
(loop )
)))
)
(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))))))
|
