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}