package require Tk

proc polygon {img colour points} {
 set l [llength $points]
 if {$l < 3} return
 # Get the start and end of the polygon shape on the x axis
 set xPoints [lmap i $points {lindex $i 0}]
 set minX [::tcl::mathfunc::int [::tcl::mathfunc::min {*}$xPoints]]
 set maxX [::tcl::mathfunc::int [::tcl::mathfunc::max {*}$xPoints]]
 # Duplicate the first point at the end, in order for the last line segement to loop back to the first point
 lappend points [lindex $points 0]
 # Create the lines from the points
 set lines {}
 for {set i 0} {$i < $l} {incr i} {
  lassign [lindex $points $i]   x1 y1
  lassign [lindex $points $i+1] x2 y2
  if {$x1==$x2 && $y1 == $y2} continue
  set x1 [expr {$x1+0.0000000000001}]; set x2 [expr {$x2+0.0000000000001}]; # stupid bodge fix.
  set slope [expr { ($y2-$y1)/double($x2-$x1) }]
  # We don't need to consider lines that are straight up vertical
  if {$slope==-Inf || $slope==Inf} continue
  lappend lines [list $x1 $x2 $y1 $slope ]
 }
 # For every vertical space
 set maxX [expr {min([image width $img],$maxX)}]
 for {set x [expr {max(0,$minX)}]} {$x < $maxX} {incr x} {
  # Get the list of intersections for this vertical line
  set intersections [lmap i $lines {
   lassign $i x1 x2 y1 slope
   if {$x<min($x1,$x2) || $x>max($x1,$x2)} continue
   expr {$y1+$slope*($x-$x1)}
  }]
  set intersections [lsort -real $intersections]
  if {[lindex $intersections 0]>=[image height $img]} continue
  if {[lindex $intersections end]<=0} continue
  # And draw the line for each polygon
  set n [llength $intersections]
  for {set j 0} {$j < ($n & -2)} {incr j 2} {
   set y1 [expr {max(0,int([lindex $intersections $j]))}]
   if {$y1>[image height $img]} break
   set y2 [expr {min([image height $img],int([lindex $intersections $j+1])) }]
   if {$y2<0} continue
   $img put $colour -to $x $y1 [expr {$x+1}] $y2
  }
 }
}

# ------ demonstration ----------

set w 640
set h 480
expr {srand(0)}
proc rnd {x} {expr {int(rand()*$x)}}
set img [image create photo -width $w -height $h]
$img put black -to 0 0 $w $h
pack [button .b -text "Clear points" -command {set points {}; $img put black -to 0 0 $w $h}]
pack [label .l -image $img]
wm title . "Polygon example - click image to add points"

for {set i 0} {$i < 10} {incr i} {
 lappend points [list [rnd $w] [rnd $h]]
}
polygon $img "#ff7f7f" $points

bind .l <ButtonPress-1> {
 lappend points [list %x %y]
 $img put black -to 0 0 $w $h
 polygon $img "#ff7f7f" $points
}

proc polygon {img colour points} {
 if {[llength $points] < 3} {return}
 set lines {}
 lappend points [lindex $points 0]
 for {set i 0} {$i < [llength $points]-1} {incr i} {
  lassign [lmap j [join [list [lrange [lindex $points $i] 0 1] [lrange [lindex $points $i+1] 0 1]]] {expr {int($j)}}] x1 y1 x2 y2
  if {$x1==$x2 && $y1==$y2} {continue}
  lappend lines [list $x1 $y1 $x2 $y2 [expr { double($x2-$x1)/double($y2-$y1) }]]
 }
 if {[llength $lines] < 3} {return}
 set minY [expr { max( 0, int([::tcl::mathfunc::min {*}[lmap i $points {lindex $i 1}]]) ) }]
 set maxY [expr { min( [image height $img], int([::tcl::mathfunc::max {*}[lmap i $points {lindex $i 1}]]) ) }]
 for {set y $minY} {$y < $maxY} {incr y} {
  set intersects {}
  foreach line $lines {
   lassign $line x1 y1 x2 y2 s
   if {$y>=min($y1,$y2) && $y<max($y1,$y2) } {
    lappend intersects [expr { $x1 + $s*($y-$y1) }]
   }
  }
  if { [llength $intersects] < 2 } {continue}
  set intersects [lsort -real $intersects]
  set intersects [lrange $intersects 0 [expr { [llength $intersects]-1-([llength $intersects]&1) }]]
  foreach {x1 x2} $intersects {
   if {$x2<=0 || $x1>=[image width $img]} {continue}
   $img put $colour -to [expr { max( 0, int( $x1 ) ) }] $y [expr { min( [image width $img], int( $x2 ) ) }] [expr {$y+1}]
  }
 }
}

proc polygon {img colour points} {
 if {! [llength $points] } {return}
 set points [join [lmap i $points {lrange $i 0 1}]]
 # Loop back to start at the end
 lappend points {*}[lrange $points 0 1]
 # Create list of lines from points
 set lines {}
 for {set i 0} {$i < [llength $points]} {incr i 2} {
  lassign [lrange $points $i $i+3] x1 y1 x2 y2
  if {$x1==$x2 && $y1==$y2} {continue}
  if {$x2 eq {} || $y2 eq {}} {continue}
  lappend lines [list $x1 $y1 $x2 $y2 [expr { ($x2-$x1)/double($y2-$y1) }]]
 }
 # For each row, find the lines intersecting, and plot. Consider this list of intersection points:
 #   o   o    o   o   o   o
 # We need to plot so that it looks like this:
 #   o---o    o---o   o---o
 # Let's go
 set yPoints [lmap {x y} $points {set y}]
 set minY [expr { int( max( 0, [::tcl::mathfunc::min {*}$yPoints ] ) ) }]
 set maxY [expr { int( min( [image height $img], [::tcl::mathfunc::max {*}$yPoints] ) ) }]
 unset yPoints
 for {set y $minY} {$y < $maxY} {incr y} {
  set intersects {}
  foreach line $lines {
   lassign $line x1 y1 x2 y2 slope
   if { $slope==Inf || $slope==-Inf } {
    if {$y==int($y1)} {lappend intersects $x1 $x2} else {continue}
   } elseif { $y >= min($y1,$y2) && $y < max($y1,$y2) } {
    lappend intersects [expr { max( 0, $x1 + $slope * ($y-$y1) ) }]
   } 
  }
  set intersects [lsort -real $intersects]
  foreach {x1 x2} $intersects {
   if {$x2 eq {}} {continue}
   $img put $colour -to [expr {int($x1)}] $y [expr {int($x2)}] [expr {$y+1}]
  }
 }
}