1 
(inpackage :ximagepolygon)

2 

3 
(defclass vertex ()

4 
((%x :initarg :x :reader x)

5 
(%y :initarg :y :reader y)

6 
(%reflexp :initform nil :accessor reflexp)

7 
(%earp :initform nil :accessor earp)

8 
(%onearstackp :initform nil :accessor onearstackp)

9 
(%next :initform nil :accessor next)

10 
(%prev :initform nil :accessor prev)))

11 

12 
;;; build a doublylinked circular list of vertices from a list of

13 
;;; points

14 
(defun buildvertices (points)

15 
(let* ((firstpoint (car points))

16 
(firstvertex (makeinstance 'vertex :x (car firstpoint) :y (cdr firstpoint)))

17 
(lastvertex firstvertex))

18 
(loop for (x . y) in (cdr points)

19 
do (let ((vertex (makeinstance 'vertex :x x :y y)))

20 
(setf (next lastvertex) vertex

21 
(prev vertex) lastvertex

22 
lastvertex vertex)))

23 
(setf (prev firstvertex) lastvertex

24 
(next lastvertex) firstvertex)

25 
firstvertex))

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 reflexpointp (x1 y1 x2 y2 x3 y3)

30 
(plusp ( (* ( y3 y1) ( x2 x1))

31 
(* ( x3 x1) ( y2 y1)))))

32 

33 
(defun insidetriangle (x y x1 y1 x2 y2 x3 y3)

34 
(and (not (reflexpointp x1 y1 x2 y2 x y))

35 
(not (reflexpointp x2 y2 x3 y3 x y))

36 
(not (reflexpointp x3 y3 x1 y1 x y))))

37 

38 
(defun reflexvertexp (vertex)

39 
(reflexpointp (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 earclipping method. This method is quadratic,

47 
;;; but fairly simple to implement.

48 
;;; We keep all the vertices in a doublylinked circular list

49 
(defun triangulatesimplepolygonwithnoholes (points fun)

50 
(declare (optimize (debug 3)))

51 
(let* ((numberofpoints (length points))

52 
(earstack (makearray numberofpoints))

53 
(earstackpointer 0)

54 
(reflexpoints (makearray numberofpoints))

55 
(numberofreflexpoints 0)

56 
(firstvertex (buildvertices points)))

57 
(loop repeat numberofpoints

58 
for vertex = firstvertex then (next vertex)

59 
do (when (reflexpointp (x (prev vertex)) (y (prev vertex))

60 
(x vertex) (y vertex)

61 
(x (next vertex)) (y (next vertex)))

62 
(setf (reflexp vertex) t)

63 
(setf (aref reflexpoints numberofreflexpoints) vertex)

64 
(incf numberofreflexpoints)))

65 
(flet ((isear (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 reflexpoint from 0

73 
do (loop until (or (= reflexpoint numberofreflexpoints)

74 
(and (reflexp (aref reflexpoints reflexpoint))

75 
(reflexp (aref reflexpoints (1 numberofreflexpoints)))))

76 
do (when (and (not (reflexp (aref reflexpoints reflexpoint)))

77 
(reflexp (aref reflexpoints (1 numberofreflexpoints))))

78 
(setf (aref reflexpoints reflexpoint)

79 
(aref reflexpoints (1 numberofreflexpoints))))

80 
do (decf numberofreflexpoints))

81 
until (= reflexpoint numberofreflexpoints)

82 
do (let* ((v (aref reflexpoints reflexpoint))

83 
(x (x v))

84 
(y (y v)))

85 
(when (and (not (eq v (prev vertex)))

86 
(not (eq v (next vertex)))

87 
(insidetriangle x y x1 y1 x2 y2 x3 y3))

88 
(return nil)))

89 
finally (return t)))))

90 
(loop repeat numberofpoints

91 
for vertex = firstvertex then (next vertex)

92 
do (when (and (not (reflexp vertex))

93 
(isear vertex))

94 
(setf (earp vertex) t)

95 
(setf (onearstackp vertex) t)

96 
(setf (aref earstack earstackpointer) vertex)

97 
(incf earstackpointer)))

98 
(finishoutput *traceoutput*)

99 
(loop repeat ( numberofpoints 3)

100 
do (loop until (earp (aref earstack (1 earstackpointer)))

101 
do (decf earstackpointer))

102 
do (let ((ear (aref earstack (decf earstackpointer))))

103 
(setf (onearstackp 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 (reflexvertexp v)

112 
(setf (reflexp v) nil)

113 
(setf (earp v) (isear v))

114 
(when (earp v)

115 
(setf (earp v) t)

116 
(unless (onearstackp v)

117 
(setf (aref earstack earstackpointer) v)

118 
(incf earstackpointer)))))

119 
(let ((v (next ear)))

120 
(unless (reflexvertexp v)

121 
(setf (reflexp v) nil)

122 
(setf (earp v) (isear v))

123 
(when (earp v)

124 
(setf (earp v) t)

125 
(unless (onearstackp v)

126 
(setf (aref earstack earstackpointer) v)

127 
(incf earstackpointer))))))))

128 
;; report the last triangle

129 
(let ((ear (aref earstack (decf earstackpointer))))

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 triangulatepolygon (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 
(triangulatesimplepolygonwithnoholes points fun)))
