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
114
115
116
117
118
119
120
121
122
123
124
|
;;; 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 (floor ,left) to (floor ,right) do
(loop for ,y from (floor ,bottom) to (floor ,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 (count 100)) &body body)
"CONTROL-POINTS is an expression that evalueates to a list of (X Y)
pairs, these are the control points for the curve.. COUNT is the
number of points on the bezier curve that will be calclated. The first
point is always the first control point and the last point is always
the last control point. Use high counts for smooth curves, as needed.
Evaluates the BODY with X Y bound to a point on the bezier curve.
"
(with-gensyms (fn points a step)
`(let* ((,step
(/ 1.0 ,count))
(,points
,control-pts)
(,fn
(apply #'bezier-lambda ,points)))
(loop for ,a from 0.0 to (+ 1.0 ,step) by ,step
for (,x ,y) = (mapcar #'round (funcall ,fn (clamp 0 ,a 1.0)))
do ,@body))))
|
