### Posted to tcl by kbk at Wed Mar 10 23:00:23 GMT 2010view raw

1. # Find intersection of an arbitrary polygon with a convex one.
2.
3. # cw --
4. #
5. # Does the path (x0,y0)->(x1,y1)->(x2,y2) turn clockwise
6. # or counterclockwise?
7. #
8. # Parameters:
9. # x0, y0 - First point
10. # x1, y1 - Second point
11. # x2, y2 - Third point
12. #
13. # Results:
14. # Returns 1 if point 2 is to the right of a line joining points 0
15. # and 1, and -1 if it is to the left of the line.
16. #
17. # If the three points are collinear, returns 1 if the third point is
18. # the middle point, -1 if point 0 is the middle point, 0 if
19. # point 1 is the middle point
20.
21. proc cw {x0 y0 x1 y1 x2 y2} {
22. set dx1 [expr {\$x1 - \$x0}]; set dy1 [expr {\$y1 - \$y0}]
23. set dx2 [expr {\$x2 - \$x0}]; set dy2 [expr {\$y2 - \$y0}]
24. # (0,0,\$dx1*\$dy2 - \$dx2*\$dy1) is the crossproduct of
25. # (\$x1-\$x0,\$y1-\$y0,0) and (\$x2-\$x0,\$y2-\$y0,0).
26. # Its z-component is positive if the turn
27. # is clockwise, negative if the turn is counterclockwise.
28. set pr1 [expr {\$dx1 * \$dy2}]
29. set pr2 [expr {\$dx2 * \$dy1}]
30. if {\$pr1 > \$pr2} {
31. # Clockwise
32. return 1
33. } elseif {\$pr1 < \$pr2} {
34. # Counter-clockwise
35. return -1
36. } elseif {\$dx1*\$dx2 < 0 || \$dy1*\$dy2 < 0} {
37. # point 0 is the middle point
38. return 0
39. } elseif {(\$dx1*\$dx1 + \$dy1*\$dy1) < (\$dx2*\$dx2 + \$dy2+\$dy2)} {
40. # point 1 is the middle point
41. return 0
42. } else {
43. # point 2 lies on the segment joining points 0 and 1
44. return 1
45. }
46. }
47.
48. # intersect --
49. #
50. # Calculate the point of intersection of two lines
51. # containing the line segments (x1,y1)-(x2,y2) and (x3,y3)-(x4,y4)
52. #
53. # Parameters:
54. # x1,y1 x2,y2 - Endpoints of the first line segment
55. # x3,y3 x4,y4 - Endpoints of the second line segment
56. #
57. # Results:
58. # Returns a two-element list containing the point of intersection.
59. # Returns an empty list if the line segments are parallel
60. # (including the case where the segments are concurrent).
61.
62. proc intersect {x1 y1 x2 y2 x3 y3 x4 y4} {
63. set d [expr {(\$y4 - \$y3) * (\$x2 - \$x1)
64. - (\$x4 - \$x3) * (\$y2 - \$y1)}]
65. set na [expr {(\$x4 - \$x3) * (\$y1 - \$y3)
66. - (\$y4 - \$y3) * (\$x1 - \$x3)}]
67. if {\$d == 0} {
68. return {}
69. }
70. set r [list \
71. [expr {\$x1 + \$na * (\$x2 - \$x1) / \$d}] \
72. [expr {\$y1 + \$na * (\$y2 - \$y1) / \$d}]]
73. return \$r
74. }
75.
76. # pairs --
77. #
78. # Coroutine that yields the elements of a list in pairs
79. #
80. # Parameters:
81. # list - List to decompose
82. #
83. # Immediate result:
84. # Returns the name of the coroutine
85. #
86. # Further results:
87. # Returns two-element ranges from the given list, one at a time.
88. # Returns {} at the end of the iteration.
89.
90. proc pairs {list} {
91. yield [info coroutine]
92. foreach {x y} \$list {
93. yield [list \$x \$y]
94. }
95. return {}
96. }
97.
98. # clipsegment --
99. #
100. # Clips one segment of a polygon against a line.
101. #
102. # Parameters:
103. # inside0 - Flag = 1 if sx0,sy0 is to the right of the clipping line
104. # cx0,cy1 cx1,cy1 - Two points determining the clipping line
105. # sx0,sy0 sx1,sy1 - Two points determining the subject line
106. #
107. # Results:
108. # Returns 1 if sx1,sy1 is to the right of the clipping line, 0 otherwise
109. #
110. # Yields:
111. # Yields, in order:
112. #
113. # The intersection point of the segment and the line, if
114. # the segment intersects the line.
115. #
116. # The endpoint of the segment, if the segment ends to the
117. # right of the line.
118.
119. proc clipsegment {inside0 cx0 cy0 cx1 cy1 sx0 sy0 sx1 sy1} {
120.
121. set inside1 [expr {[cw \$cx0 \$cy0 \$cx1 \$cy1 \$sx1 \$sy1] > 0}]
122. if {\$inside1} {
123. if {!\$inside0} {
124. set int [intersect \$cx0 \$cy0 \$cx1 \$cy1 \
125. \$sx0 \$sy0 \$sx1 \$sy1]
126. if {[llength \$int] >= 0} {
127. yield \$int
128. }
129. }
130. yield [list \$sx1 \$sy1]
131. } else {
132. if {\$inside0} {
133. set int [intersect \$cx0 \$cy0 \$cx1 \$cy1 \
134. \$sx0 \$sy0 \$sx1 \$sy1]
135. if {[llength \$int] >= 0} {
136. yield \$int
137. }
138. }
139. }
140. return \$inside1
141. }
142.
143. # clipstep --
144. #
145. # Coroutine to perform one step of Sutherland-Hodgman polygon clipping
146. #
147. # Parameters:
148. # source - Name of a coroutine that will return the vertices of a
149. # subject polygon to clip, and return {} at the end of the
150. # iteration.
151. # cx0,cy0 cx1,cy1 - Endpoints of an edge of the clip polygon
152. #
153. # Immediate result:
154. # Returns the name of the coroutine
155. #
156. # Further results:
157. # Returns the vertices of the clipped polygon
158.
159. proc clipstep {source cx0 cy0 cx1 cy1} {
160. yield [info coroutine]
161. set pt0 [{*}\$source]
162. if {[llength \$pt0] == 0} {
163. return
164. }
165. lassign \$pt0 sx0 sy0
166. set inside0 [expr {[cw \$cx0 \$cy0 \$cx1 \$cy1 \$sx0 \$sy0] > 0}]
167. set finished 0
168. while {!\$finished} {
169. set thispt [{*}\$source]
170. if {[llength \$thispt] == 0} {
171. set thispt \$pt0
172. set finished 1
173. }
174. lassign \$thispt sx1 sy1
175. set inside0 [clipsegment \$inside0 \
176. \$cx0 \$cy0 \$cx1 \$cy1 \$sx0 \$sy0 \$sx1 \$sy1]
177. set sx0 \$sx1
178. set sy0 \$sy1
179. }
180. return {}
181. }
182.
183. # clippoly --
184. #
185. # Perform Sutherland-Hodgman polygon clipping
186. #
187. # Parameters:
188. # cpoly - Coordinates of the clip polygon, listed in clockwise order.
189. # spoly - Coordinates of the subject polygon, listed in clockwise order.
190. #
191. # Results:
192. # Returns the coordinates of the clipped polygon, listed in clockwise
193. # order.
194. #
195. # The clip polygon must be convex. The subject polygon may be any polygon,
196. # including degenerate and self-intersecting ones.
197.
198. proc clippoly {cpoly spoly} {
199. variable clipindx
200. set source [coroutine clipper[incr clipindx] \
201. pairs \$spoly]
202. set cx0 [lindex \$cpoly end-1]
203. set cy0 [lindex \$cpoly end]
204. foreach {cx1 cy1} \$cpoly {
205. set source [coroutine clipper[incr clipindx] \
206. clipstep \$source \$cx0 \$cy0 \$cx1 \$cy1]
207. set cx0 \$cx1; set cy0 \$cy1
208. }
209. set result {}
210. while {[llength [set pt [{*}\$source]]] > 0} {
211. lappend result {*}\$pt
212. }
213. return \$result
214. }
215.
216. if {![info exists ::argv0] || [string compare \$::argv0 [info script]]} {
217. return
218. }
219.
220. package require Tk
221.
222. grid [canvas .c -width 400 -height 400 -background \#ffffff]
223. proc demonstrate {cpoly spoly} {
224. .c create polygon {*}\$cpoly -outline \#ff9999 -fill {} \
225. -width 5
226. .c create polygon {*}\$spoly -outline \#9999ff -fill {} \
227. -width 3
228. .c create polygon {*}[clippoly \$cpoly \$spoly] \
229. -fill \#99ff99 -outline black -width 1
230. }
231.
232. demonstrate {100 100 300 100 300 300 100 300} \
233. {50 150 200 50 350 150 350 300 250 300 200 250 150 350 100 250 100 200}