/
test-geometry.lisp
155 lines (141 loc) · 5.44 KB
/
test-geometry.lisp
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
(defpackage :test-geometry (:use :common-lisp :2d-geometry :vecto :iterate)
(:export #:test-triangulate
#:test-decompose
#:test-bentley-ottmann
#:test-decompose-bo
#:test-decompose-triangle))
(in-package :test-geometry)
(defparameter *test-polygon*
(make-polygon-from-coords
10 10 20 20 20 70 70 70 70 20)
"Test concave polygon")
(defparameter *test-polygon2*
(make-polygon-from-coords
20 20 10 40 20 70 70 70 70 20)
"Test convex polygon")
(defparameter *test-polygon3*
(make-polygon-from-coords
20 20 10 40 70 40 70 70)
"Test small complex polygon")
(defparameter *test-polygon4*
(make-polygon-from-coords
20 20 10 30 70 15 70 40 30 35 50 10 45 35 25 60))
(defun test-triangulate (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgb-fill 0 0 0.8)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk point-list)
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-path)
(set-rgb-stroke 0 1.0 0)
(set-line-width 2)
(set-line-join :bevel)
(dolist (tk (triangulate polygon))
(let ((point-list (point-list tk)))
(move-to (x (car point-list))(y (car point-list)))
(dolist (kk (cdr point-list))
(line-to (x kk)(y kk)))
(line-to (x (car point-list))(y (car point-list)))
(stroke)))
(save-png "test-geometry.png"))))
;; (test-triangulate *test-polygon* 100 100)
;; (test-triangulate *test-polygon2* 100 100)
(defun test-decompose (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk point-list)
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-nondisjoint polygon)))
(dolist (tk (mapcar #'point-list d-polys))
(translate 100 0)
(set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
(move-to (x (car tk))(y (car tk)))
(dolist (kk (cdr tk))
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png"))))
;; (test-decompose *test-polygon3* 300 100)
;; (test-decompose *test-polygon4* 400 100)
(defun test-bentley-ottmann (polygon)
(if (frustrated-polygon-p polygon)
'frustrated
(let ((in-points (bentley-ottmann (edge-list polygon)))
(point-list (point-list polygon)))
(with-canvas (:width 400 :height 400)
(scale 4 4)
(set-rgb-stroke 0 0 1.0)
(set-line-width 1/5)
(move-to (x (car point-list))
(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(stroke)
(set-rgba-fill 0 1.0 0 0.4)
(dolist (tk in-points)
(set-rgba-stroke (random 1.0) (random 1.0) (random 0.5) 0.5)
(move-to 0 (y tk))
(line-to 100 (y tk))
(move-to (x tk) 0)
(line-to (x tk) 100)
(stroke)
(centered-circle-path (x tk)(y tk) 1)
(fill-path))
(save-png "test-geometry.png")))))
;; (test-bentley-ottmann *test-polygon3*)
;; (test-bentley-ottmann *test-polygon4*)
(defun test-decompose-bo (polygon w h &optional (x 0) (y 0))
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate x y)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon)))
(dolist (tk (mapcar #'point-list d-polys))
(translate 100 0)
(set-rgba-fill (random 1.0)(random 1.0)(random 1.0) 1.0)
(move-to (x (car tk))(y (car tk)))
(dolist (kk (cdr tk))
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png"))))
;;(test-decompose-bo *test-polygon3* 300 100)
;;(test-decompose-bo *test-polygon4* 400 100)
(defun test-decompose-triangle (polygon w h)
(let ((point-list (point-list polygon)))
(with-canvas (:width w :height h)
(translate 10 10)
(set-rgba-fill 0 0 0.8 1.0)
(set-rgba-stroke 0 0.8 0 0.5)
(move-to (x (car point-list))(y (car point-list)))
(dolist (tk (cdr point-list))
(line-to (x tk)(y tk)))
(line-to (x (car point-list))(y (car point-list)))
(even-odd-fill-and-stroke)
(translate 0 0)
(let ((d-polys (mapcar #'point-list
(decompose-complex-polygon-triangles polygon :in-test 'geometry:point-in-polygon-crossing-p))))
(set-rgba-fill 0 1.0 0 0.2)
(dolist (tk d-polys)
(move-to (x (car tk))(y (car tk)))
(dolist (kk tk)
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-and-stroke)))
(save-png "test-geometry.png"))))