/[geometry]/geometry/polygon.lisp
ViewVC logotype

Contents of /geometry/polygon.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Thu Oct 4 05:58:00 2007 UTC (6 years, 6 months ago) by rstrandh
Branch: rstrandh, MAIN
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
initial import
1 (in-package :ximage-polygon)
2
3 (defclass vertex ()
4 ((%x :initarg :x :reader x)
5 (%y :initarg :y :reader y)
6 (%reflex-p :initform nil :accessor reflex-p)
7 (%ear-p :initform nil :accessor ear-p)
8 (%on-ear-stack-p :initform nil :accessor on-ear-stack-p)
9 (%next :initform nil :accessor next)
10 (%prev :initform nil :accessor prev)))
11
12 ;;; build a doubly-linked circular list of vertices from a list of
13 ;;; points
14 (defun build-vertices (points)
15 (let* ((first-point (car points))
16 (first-vertex (make-instance 'vertex :x (car first-point) :y (cdr first-point)))
17 (last-vertex first-vertex))
18 (loop for (x . y) in (cdr points)
19 do (let ((vertex (make-instance 'vertex :x x :y y)))
20 (setf (next last-vertex) vertex
21 (prev vertex) last-vertex
22 last-vertex vertex)))
23 (setf (prev first-vertex) last-vertex
24 (next last-vertex) first-vertex)
25 first-vertex))
26
27 ;;; return t if there is a turn to the left in point 2 going from
28 ;;; point 1 to point 3
29 (defun reflex-point-p (x1 y1 x2 y2 x3 y3)
30 (plusp (- (* (- y3 y1) (- x2 x1))
31 (* (- x3 x1) (- y2 y1)))))
32
33 (defun inside-triangle (x y x1 y1 x2 y2 x3 y3)
34 (and (not (reflex-point-p x1 y1 x2 y2 x y))
35 (not (reflex-point-p x2 y2 x3 y3 x y))
36 (not (reflex-point-p x3 y3 x1 y1 x y))))
37
38 (defun reflex-vertex-p (vertex)
39 (reflex-point-p (x (prev vertex))
40 (y (prev vertex))
41 (x vertex)
42 (y vertex)
43 (x (next vertex))
44 (y (next vertex))))
45
46 ;;; use the ear-clipping method. This method is quadratic,
47 ;;; but fairly simple to implement.
48 ;;; We keep all the vertices in a doubly-linked circular list
49 (defun triangulate-simple-polygon-with-no-holes (points fun)
50 (declare (optimize (debug 3)))
51 (let* ((number-of-points (length points))
52 (ear-stack (make-array number-of-points))
53 (ear-stack-pointer 0)
54 (reflex-points (make-array number-of-points))
55 (number-of-reflex-points 0)
56 (first-vertex (build-vertices points)))
57 (loop repeat number-of-points
58 for vertex = first-vertex then (next vertex)
59 do (when (reflex-point-p (x (prev vertex)) (y (prev vertex))
60 (x vertex) (y vertex)
61 (x (next vertex)) (y (next vertex)))
62 (setf (reflex-p vertex) t)
63 (setf (aref reflex-points number-of-reflex-points) vertex)
64 (incf number-of-reflex-points)))
65 (flet ((is-ear (vertex)
66 (let ((x1 (x (prev vertex)))
67 (y1 (y (prev vertex)))
68 (x2 (x vertex))
69 (y2 (y vertex))
70 (x3 (x (next vertex)))
71 (y3 (y (next vertex))))
72 (loop for reflex-point from 0
73 do (loop until (or (= reflex-point number-of-reflex-points)
74 (and (reflex-p (aref reflex-points reflex-point))
75 (reflex-p (aref reflex-points (1- number-of-reflex-points)))))
76 do (when (and (not (reflex-p (aref reflex-points reflex-point)))
77 (reflex-p (aref reflex-points (1- number-of-reflex-points))))
78 (setf (aref reflex-points reflex-point)
79 (aref reflex-points (1- number-of-reflex-points))))
80 do (decf number-of-reflex-points))
81 until (= reflex-point number-of-reflex-points)
82 do (let* ((v (aref reflex-points reflex-point))
83 (x (x v))
84 (y (y v)))
85 (when (and (not (eq v (prev vertex)))
86 (not (eq v (next vertex)))
87 (inside-triangle x y x1 y1 x2 y2 x3 y3))
88 (return nil)))
89 finally (return t)))))
90 (loop repeat number-of-points
91 for vertex = first-vertex then (next vertex)
92 do (when (and (not (reflex-p vertex))
93 (is-ear vertex))
94 (setf (ear-p vertex) t)
95 (setf (on-ear-stack-p vertex) t)
96 (setf (aref ear-stack ear-stack-pointer) vertex)
97 (incf ear-stack-pointer)))
98 (finish-output *trace-output*)
99 (loop repeat (- number-of-points 3)
100 do (loop until (ear-p (aref ear-stack (1- ear-stack-pointer)))
101 do (decf ear-stack-pointer))
102 do (let ((ear (aref ear-stack (decf ear-stack-pointer))))
103 (setf (on-ear-stack-p ear) nil)
104 (funcall fun
105 (x (prev ear)) (y (prev ear))
106 (x ear) (y ear)
107 (x (next ear)) (y (next ear)))
108 (setf (next (prev ear)) (next ear)
109 (prev (next ear)) (prev ear))
110 (let ((v (prev ear)))
111 (unless (reflex-vertex-p v)
112 (setf (reflex-p v) nil)
113 (setf (ear-p v) (is-ear v))
114 (when (ear-p v)
115 (setf (ear-p v) t)
116 (unless (on-ear-stack-p v)
117 (setf (aref ear-stack ear-stack-pointer) v)
118 (incf ear-stack-pointer)))))
119 (let ((v (next ear)))
120 (unless (reflex-vertex-p v)
121 (setf (reflex-p v) nil)
122 (setf (ear-p v) (is-ear v))
123 (when (ear-p v)
124 (setf (ear-p v) t)
125 (unless (on-ear-stack-p v)
126 (setf (aref ear-stack ear-stack-pointer) v)
127 (incf ear-stack-pointer))))))))
128 ;; report the last triangle
129 (let ((ear (aref ear-stack (decf ear-stack-pointer))))
130 (funcall fun
131 (x (prev ear)) (y (prev ear))
132 (x ear) (y ear)
133 (x (next ear)) (y (next ear))))))
134
135 (defun triangulate-polygon (points fun)
136 (let ((area (loop repeat (length points)
137 for ((x1 . y1) (x2 . y2) . rest) on (append points (list (car points)))
138 sum (- (* x1 y2) (* x2 y1)))))
139 (when (plusp area)
140 (setf points (reverse points)))
141 (triangulate-simple-polygon-with-no-holes points fun)))

  ViewVC Help
Powered by ViewVC 1.1.5