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
125
126
127
128
129
|
;;;; utils.lisp
(in-package #:wheelwork)
(define-symbol-macro +pi-over-180+ 0.017453292519943295d0)
(defun radians (degrees)
"Converse DEGREES to radians"
(* degrees +pi-over-180+))
(defun safe-slot (object slot &optional default)
(if-let (val (and (slot-exists-p object slot)
(slot-boundp object slot)
(slot-value object slot)))
val
default))
(defun counterclockwisep (a b c)
"A B and C are vectors created by 3d-vectors:vec, each representing
a 2d point. Returns T if the three are supplied in counterclockwise
order, nil if not."
(> (* (- (vec:vx b) (vec:vx a))
(- (vec:vy c) (vec:vy a)))
(* (- (vec:vy b) (vec:vy a))
(- (vec:vx c) (vec:vx a)))))
(defun segments-intersect-p (a b c d)
"A B C and D are vectors of the sort created by 3d-vectors:vec,
each representing a 2d point. Returns T if the line segment between A
and B intersects the linesegment between C and D, NIL otherwise."
(or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d)
(and (not (eq (counterclockwisep a c d) (counterclockwisep b c d)))
(not (eq (counterclockwisep a b c) (counterclockwisep a b d))))))
(defun paths-intersect-p (path-a path-b)
"Paths are lists of vectors, each of which represents a 2d point."
(loop for (a1 a2 . more-a) on path-a
while a2
thereis (loop for (b1 b2 . b-more) on path-b
while b2
thereis (segments-intersect-p a1 a2 b1 b2))))
(defun closed-path-p (path)
(equalp (first path)
(first (last path))))
(defun path-encloses-point-p (path pt)
"Path is a list of vectors, pt is a single vector."
(assert (closed-path-p path) () "Enclosing path must be a closed path.")
(let* ((bounds
(path-bounds path))
(corner
;; creating a point guaranteed to be outside of the path
(vec:vec (- (getf bounds :left) (getf bounds :width))
(- (getf bounds :bottom) (getf bounds :height))
0.0 1.0)))
(loop for (p1 p2 . more) on path
while p2
when (segments-intersect-p p1 p2 pt corner)
count 1 into intersection-count
finally
(return (oddp intersection-count)))))
(defun path-encloses-path-p (path-a path-b)
"T if path-b is totally contained in path-a and does not intersect path-a"
(assert (closed-path-p path-a) () "Enclosing path must be a closed path.")
(and
(loop for (p1 p2 . more) on path-b
while p2
always (path-encloses-point-p path-a p1))
(not (paths-intersect-p path-a path-b))))
(defun path-bounds (path)
"Path is a list of vectors representing 2d points. Returns the
bounds and width and height as a plist of the form
(:top N :left N :right N :bottom N :width N :height N)
This is the smallest UNROTATED RECTANGLE that contains the points in
the path."
(loop
with max-x = nil
and max-y = nil
and min-x = nil
and min-y = nil
for vec in path
for x = (vec:vx vec)
for y = (vec:vy vec)
when (or (null max-x) (< max-x x))
do (setf max-x x)
when (or (null min-x) (< x min-x))
do (setf min-x x)
when (or (null max-y) (< max-y y))
do (setf max-y y)
when (or (null min-y) (< y min-y))
do (setf min-y y)
finally
(return (list :top max-y :left min-x :right max-x :bottom min-y
:width (- max-x min-x)
:height (- max-y min-y)))))
(defmacro setf-many (places-and-value)
"e.g. (setf-many a b c 10) would set a b and c to 10"
(let ((value-form
(first (last places-and-value))))
`(setf ,@(butlast places-and-value) ,value-form)))
(defmacro with-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)
`(let* ((,sx ,start-x)
(,sy ,start-y)
(,ex ,end-x)
(,ey ,end-y)
(,xdiff (- ,ex ,sx))
(,ydiff (- ,ey ,sy))
(,distance (max (abs ,xdiff) (abs ,ydiff))))
(loop 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)))))
|
