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))))
|
