Richard Suchenwirth 2004-07-22 - Given the coordinates of two convex polygons (in the same meaning as canvas items), I wanted to determine the coordinates of the polygon where the two overlap. You can interpret this also as the intersection, if the two polygons represent sets of points inside them.
The idea was: The overlap polygon is bounded by the convex hull of those points where
Enclosure of a point in a polygon was tested by checking whether the line between the point and another that is known to be inside the polygon (namely, its center :) crosses no boundaries of the polygon. So both criteria could be simplified down to checking whether, and if so, where, two lines cross.
And here's the code (make sure the functions ccw and hull2d from Convex hull are also available):
namespace eval polygon {}
proc polygon::overlap {p1 p2} {
set res {}
set lines2 [sides $p2]
#-- collect crossing points
foreach a [sides $p1] {
foreach b $lines2 {
set point [lines'cross $a $b]
if {$point ne ""} {lappend res $point}
}
}
#-- collects points of one polygon enclosed in the other
foreach a [corners $p1] {
if [enclosed $p2 $a] {lappend res $a}
}
foreach a [corners $p2] {
if [enclosed $p1 $a] {lappend res $a}
}
join [hull2d $res]
}
proc polygon::center coords {
# returns the x y coordinates of the center
set xsum 0.0
set ysum 0.0
set n 0
foreach {x y} $coords {
+= xsum $x
+= ysum $y
incr n
}
list [expr {$xsum/$n}] [expr {$ysum/$n}]
}
proc polygon::enclosed {coords point} {
set testline [concat $point [center $coords]]
foreach side [sides $coords] {
if {[lines'cross $side $testline] ne ""} {return 0}
}
return 1
}
proc polygon::sides coords {
foreach {x0 y0} $coords break
set res {}
foreach {x y} [lrange $coords 2 end] {
lappend res [list $x0 $y0 $x $y]
set x0 $x
set y0 $y
}
lappend res [list $x $y [lindex $coords 0] [lindex $coords 1]]
}
proc polygon::corners coords {
set res {}
foreach {x y} $coords {
lappend res [list $x $y]
}
set res
}# This took me most thinking - find out whether (and where) two lines cross
proc lines'cross {line1 line2} {
#-- return crossing point of 2 line segments, or {} if not crossing
foreach {xa ya xb yb} $line1 break
foreach {xc yc xd yd} $line2 break
if {$xa == $xb} {
if {$xc == $xd} return ;# parallels
set n [expr {($yd-$yc)/double($xd-$xc)}]
set b [expr {$yc - $n*$xc}]
set x $xa
set y [expr {$n*$x + $b}]
} else {
set m [expr {($yb-$ya)/double($xb-$xa)}]
set a [expr {$ya - $m*$xa}]
if {$xc == $xd} {
set x $xc
} else {
set n [expr {($yd-$yc)/double($xd-$xc)}]
if {$m == $n} return ;# parallels
set b [expr {$yc - $n*$xc}]
set x [expr {($b-$a)/($m-$n)}]
}
set y [expr {$m*$x + $a}]
}
# added little epsilons for float comparison
if {$x < [min $xa $xb]-.1 || $x > [max $xa $xb]+.1
|| $x < [min $xc $xd]-.1 || $x > [max $xc $xd]+.1
} return
if {$y < [min $ya $yb]-.1 || $y > [max $ya $yb]+.1
|| $y < [min $yc $yd]-.1 || $y > [max $yc $yd]+.1
} return
return [list $x $y]
}
proc min {a b} {expr {$a < $b? $a : $b}}
proc max {a b} {expr {$a > $b? $a : $b}}
proc += {varName amount} {
upvar 1 $varName var
set var [expr {$var+$amount}]
}RS 2004-08-05: because of a real problem, had to add epsilons in the exclusion checks (happening when one line was exactly horizontal)
KBK 2004-08-06: Would recasting [lines'cross] as the following code help with your epsilons? It makes a fairly conventional parametrization (see the comments at the head of the code) that allows finding the point of intersection by solving a system of linear equations. The parameters are chosen so that they will both lie in the interval [-1,1] if the line segments intersect; this allows testing them before attempting any dangerous divisions.
# Let the point of intersection of the two lines be (x,y)
# 2x = xa * (1-p) + xb * (1+p) = xc * (1-q) + xd * (1+q)
# 2y = ya * (1-p) + yb * (1+p) = yc * (1-q) + yd * (1+q)
# The point of intersection lies within the first line segment
# if and only if p<=1, and within the second line segment
# if and only if q<=1. We recast this into a 2x2 linear
# system and solve. We avoid dividing by the determinant
# until we've determined that both intersections lie within
# the lines in question
proc lines'cross { line1 line2 } {
foreach { xa ya xb yb } $line1 break
foreach { xc yc xd yd } $line2 break
set det [expr { ( $xb - $xa ) * ( $yd - $yc )
- ( $xd - $xc ) * ( $yb - $ya ) }]
if { $det == 0 } { # line segments are parallel
# or collinear
return {}
}
set nump [expr { ( $xd - $xc ) * ( $yb + $ya )
- ( $xb + $xa ) * ( $yd - $yc )
+ 2. * ( $xc * $yd - $xd * $yc ) }]
if { abs($nump) > abs($det) } { # point of intersection is
# outside first line segment
return
}
set numq [expr { ( $xd + $xc ) * ( $yb - $ya )
- ( $xb - $xa ) * ( $yd + $yc )
+ 2. * ( $xb * $ya - $xa * $yb ) }]
if { abs($numq) > abs($det) } { # point of intersction is
# outside second line segment
return
}
set p [expr { $nump / $det }]
set opp [expr { 1. + $p }]
set omp [expr { 1. - $p }]
set x [expr { ($xa * $omp + $xb * $opp) / 2. }]
set y [expr { ($ya * $omp + $yb * $opp) / 2. }]
return [list $x $y]
}