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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
;;; 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))))
(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)))))
(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 (or interiorp autoclosep)
`(destructuring-bind (,x2 ,y2) (first ,points)
(with-grid-line (,x ,y) (,x2 ,y2) (,x1 ,y1)
,@body))))
(interior-clause
(when 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 )))
(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))
(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)))))))
(defmacro with-grid-bezier
((x y) (control-pts &key (step 0.001)) &body body)
(with-gensyms (fn points a)
`(let* ((,points
,control-pts)
(,fn
(apply #'bezier-lambda ,points)))
(loop for ,a from 0.0 to 1.0 by ,step
for (,x ,y) = (mapcar #'round (funcall ,fn ,a))
do ,@body))))
|
