-
Notifications
You must be signed in to change notification settings - Fork 16
/
trapezoidation.lisp
128 lines (121 loc) · 7.02 KB
/
trapezoidation.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
(in-package :2d-geometry)
;;;; This files contains function for trapeziodation of complex polygons, with the ultimate goal of
;;;; decomposing them into simple, disjoint polygons (trapezoids, which can be joined back into
;;;; larger polygons if desired, albeit slowly).
;;;; This is somewhat different than trapezoidation for efficient triangulation, but it may be possible to
;;;; modify this code to do that. That is, it will work, but it may or may be not faster than ear removal.
(defun orient-edge-right (edge)
"Returns an edge oriented up. It makes a new object event if argument is already up."
(if (> (x (start edge))(x (end edge)))
(make-instance 'line-segment
:start (end edge)
:end (start edge))
(make-instance 'line-segment
:start (start edge)
:end (end edge))))
(defun vertical-edge-p (edge)
"Returns t if edge is horizontal."
(= (x (start edge))(x (end edge))))
(defun trapezoidize-edges (edge-list)
"Returns a list of trapezoids build from a set of edges and their bounding box."
(let ((clean-edge-list (mapcar #'orient-edge-right (remove-if #'vertical-edge-p edge-list))))
;vertical edges only create problems when trapezoidating
(let ((endpoints (create-initial-event-list clean-edge-list))
(intersections (bentley-ottmann clean-edge-list)))
(destructuring-bind (min-y . max-y)
(iterate (for i in endpoints)
(maximizing (y i) into max-y)
(minimizing (y i) into min-y)
(finally (return (cons min-y max-y))))
(let ((event-queue (sort (append endpoints intersections) #'point-sort-fun))
(sweep-line (make-instance 'sweep-line))
(trapezoids nil))
;init sweep-line
(let ((init-x (x (car event-queue))))
(iterate (while (and event-queue
(= (x (car event-queue)) init-x)))
(let ((event (pop event-queue)))
(move-sweep-line sweep-line (x event)(y event))
(insert-edge (edge event) sweep-line))))
(iterate (while event-queue)
;generate trapezoids
(let ((prev-edge (make-instance 'line-segment
:start
(make-instance 'point
:x (x sweep-line)
:y max-y)
:end
(make-instance 'point
:x (x (car event-queue))
:y max-y)))
(event (car event-queue)))
(trees:dotree (tk (edge-tree sweep-line))
;ignore edges on bounding box
(unless (or (and (= (y (start tk)) min-y)
(= (y (end tk)) min-y))
(and (= (y (start tk)) max-y)
(= (y (end tk)) max-y)))
(let ((inters1-y (y (lines-intersection-point
(line-from-segment tk)
(make-instance 'line :a 1 :b 0 :c (- (x event))))))
(inters2-y (y (lines-intersection-point
(line-from-segment prev-edge)
(make-instance 'line :a 1 :b 0 :c (- (x event)))))))
(push (coords-to-points
(x sweep-line)(y (start prev-edge))
(x event) inters2-y
(x event) inters1-y
(x sweep-line)(y (start tk)))
trapezoids))
(setf prev-edge tk)))
;terminate with upper bounding edge
(push (coords-to-points
(x sweep-line)(y (start prev-edge))
(x event)(y (lines-intersection-point
(line-from-segment prev-edge)
(make-instance 'line :a 1 :b 0 :c (- (x event)))))
(x event) min-y
(x sweep-line) min-y)
trapezoids)
;truncate edges
(trees:dotree (tk (edge-tree sweep-line))
(unless (= (x event)
(x (end tk)))
(let ((inters-y (y (lines-intersection-point
(line-from-segment tk)
(make-instance 'line :a 1 :b 0 :c (- (x event)))))))
(setf (start tk)
(make-instance 'point
:x (x event)
:y inters-y))))))
;shift sweep line
(let ((new-x (x (car event-queue))))
(iterate (while (and event-queue
(= (x (car event-queue)) new-x)))
(for event next (pop event-queue))
(etypecase event
(event-endpoint
(case (direction event)
(right
(delete-edge (edge event) sweep-line)
(unless (or (null event-queue)
(point-equal-p (car event-queue) event))
(move-sweep-line sweep-line (x event)(y event))))
(left
(move-sweep-line sweep-line (x event)(y event))
(insert-edge (edge event) sweep-line))))
(event-intersection
(delete-edge (edge1 event) sweep-line)
(delete-edge (edge2 event) sweep-line)
(move-sweep-line sweep-line (x event)(y event))
(insert-edge (edge1 event) sweep-line)
(insert-edge (edge2 event) sweep-line))))))
(nreverse trapezoids))))))
(defun collapse-trapezoid (trapezoid)
"Reduce degenerate trapezoids to triangles."
(remove-duplicates trapezoid :test #'point-equal-p))
(defun split-trapezoid (trapezoid)
"Split trapezoid into two triangles. Return a cons."
(destructuring-bind (v1 v2 v3 v4) trapezoid
(cons (list v1 v2 v3)
(list v3 v4 v1))))