-
Notifications
You must be signed in to change notification settings - Fork 16
/
test-geometry.lisp
95 lines (90 loc) · 2.95 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
(defpackage :test-geometry (:use :common-lisp :2d-geometry :vecto :iterate)
(:export #:test-triangulate
#:test-decompose
#:test-bentley-ottmann
#:test-decompose-bo))
(in-package :test-geometry)
(defun test-triangulate (polygon w h &optional (x 0) (y 0))
(with-canvas (:width w :height h)
(translate x y)
(set-rgb-fill 0 0 0.8)
(move-to (x (car polygon))(y (car polygon)))
(dolist (tk polygon)
(line-to (x tk)(y tk)))
(line-to (x (car polygon))(y (car polygon)))
(fill-path)
(set-rgb-stroke 0 1.0 0)
(set-line-width 2)
(set-line-join :bevel)
(dolist (tk (triangulate polygon))
(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))))
(stroke)
(save-png "test-geometry.png")))
(defun test-decompose (polygon w h &optional (x 0) (y 0))
(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 polygon))(y (car polygon)))
(dolist (tk polygon)
(line-to (x tk)(y tk)))
(line-to (x (car polygon))(y (car polygon)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-nondisjoint polygon)))
(dolist (tk 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 tk)
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png")))
(defun test-bentley-ottmann (polygon)
(if (frustrated-polygon-p polygon)
'frustrated
(let ((in-points (bentley-ottmann (geometry::edge-list-from-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 polygon))
(y (car polygon)))
(dolist (tk polygon)
(line-to (x tk)(y tk)))
(line-to (x (car polygon))(y (car polygon)))
(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")))))
(defun test-decompose-bo (polygon w h &optional (x 0) (y 0))
(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 polygon))(y (car polygon)))
(dolist (tk polygon)
(line-to (x tk)(y tk)))
(line-to (x (car polygon))(y (car polygon)))
(fill-and-stroke)
(let ((d-polys (decompose-complex-polygon-bentley-ottmann polygon)))
(dolist (tk 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 tk)
(line-to (x kk)(y kk)))
(line-to (x (car tk))(y (car tk)))
(fill-path)))
(save-png "test-geometry.png")))