#!/usr/bin/perl -w
##################################################### 
### Copyright (c) 2002 Russell B Cecala. All rights 
### reserved.  This program is free software; you can 
### redistribute it and/or modify it under the same 
### terms as Perl itself. 
##################################################### 
use strict;
use Data::Dumper;
use Math::Round qw( nearest_floor nearest_ceil );
use Tk;
use Tk::Canvas;

my $width = 320;
my $height = 200;

#adjust these vectors for shape 
my $A = new Vector2D(  90 +  30, $height -  70 );
my $B = new Vector2D(  80 +  170, $height -  50 );
my $C = new Vector2D( 180 + 30, $height -  90 );
my $D = new Vector2D(  80 + 180, $height - 150 );
my $E = new Vector2D(  50 +  90, $height - 110 );
my $F = new Vector2D(  68 +  70, $height - 130 );

my @AB = [ $A, $B ];
my @BC = [ $B, $C ];
my @CD = [ $C, $D ];
my @DE = [ $D, $E ];
my @EF = [ $E, $F ];
my @FA = [ $F, $A ];

my @edges = ( @AB, @BC, @CD, @DE, @EF, @FA );

my $top = MainWindow->new();
my $can = $top->Canvas( -width => $width, -height=> $height, -background=>'white' )->pack();

my $polygon = new Polygon( \@edges, $can, 126 );


$polygon->fill();

MainLoop;

BEGIN {
{
package Polygon;
use strict;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

use Data::Dumper;
use Math::Round qw( nearest_floor nearest_ceil );
use Tk;
use Tk::Canvas;

$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT      = ();

sub new  {
my ($pkg, $polygon, $canvas, $color) = @_;
my $highestY  = getHighestY($polygon);

bless {
polygon => $polygon, # ref to array of pairs of Vector2D 
ET      => undef,       # edge table 
highestY        => $highestY,
can     => $canvas,  #Tk canvas 
color   => $color
}, $pkg;
}

sub dumpET {
my $pkg         = shift;
my $et          = $pkg->{ET};
my $highestY    = $pkg->{highestY};

for my $i (0..$highestY-1) {
if ( @{$et}[$i] ) {
print "et[$i] = ";
for my $list ( @{$et}[$i] ) {
for my $r ( @{$list} ) {
print "{" . %{$r}->{Ymax} . "|" . %{$r}->{Xbot} . "|" . %{$r}->{invSlope} . "}" ;
}
}
print "\n";
} else {
print "et[$i] = NULL\n";
}
}
}

sub buildET {
my $pkg = shift;
# each entry in the Edge Table (ET) contains the Ymax coordinate of the edge, 
# the x cooridnate of the bottom endpoint Xbot and the x increment 
# used in the stepping from one scan lime to the next 1/m 
for my $edge (@{$pkg->{polygon}}) {
my $y    = ( @{$edge}->[0]->gety() <  @{$edge}->[1]->gety() ) ? @{$edge}->[0]->gety() : @{$edge}->[1]->gety() ;
my $Ymax = ( @{$edge}->[0]->gety() >= @{$edge}->[1]->gety() ) ? @{$edge}->[0]->gety() : @{$edge}->[1]->gety() ;
my $Xbot = ( @{$edge}->[0]->gety() <  @{$edge}->[1]->gety() ) ? @{$edge}->[0]->getx() : @{$edge}->[1]->getx() ;

my $invSlope    = &calcOneOverSlope($edge);
my $rec = {
Ymax            => $Ymax,
Xbot            => $Xbot,
invSlope        => $invSlope,
};
push( @{$pkg->{ET}[$y]}, $rec );
}
my $highestY = $pkg->{highestY};
for my $i (0..$highestY-1) { if ( $pkg->{ET}[$i] ) { return $i; } }
}

################################################# 
### 
###     fill is based on the algorthim described 
###     in "Computer Graphics Principles and 
###     Practice" Foley, van Dam, Feiner, and 
###     Hughes 2nd edition (pg 92-99) 
### 
################################################# 
sub fill {
my $pkg = shift;
my $color = $pkg->{color};
my $y   = $pkg->buildET();
my @ET  = @{$pkg->{ET}};
my @AET;        # Active Edge Table 

do {
# print "================== doing scan line $y ================\n"; 
# Move from ET bucket y to the AET those edges whose Ymin = y 
if ( $ET[$y] ) {
while( @{$ET[$y]} ) {
my $e = pop( @{$ET[$y]} );
push( @AET, $e );
}
$ET[$y] = undef;
}

# then sort AET on x 
@AET = sort{ %{$a}->{Xbot} <=> %{$b}->{Xbot} } @AET;

my $last;
for ( my $i=0; $i<$#AET+1; ) {
my $X1;
my $X2;
my $x1 = $AET[$i++];
my $x2 = $AET[$i++];
if ( $x2 ) {
$last = $x2;
$X1 = nearest_ceil(1,%{$x1}->{Xbot});
$X2 = nearest_floor(1,%{$x2}->{Xbot});
} else {
$X1 = nearest_ceil(1,%{$last}->{Xbot});
$X2 = nearest_floor(1,%{$x1}->{Xbot});
}
for my $x ( $X1..$X2 ) { $pkg->setPixel( $x, $y, $color ); }
}
my @AET_copy; # = @AET; 
while( @AET ) {
my $e = pop( @AET );
if ( %{$e}->{Ymax} != $y ) { push( @AET_copy, $e ); }
}
$y++;
@AET = @AET_copy;

for ( my $i=0; $i<$#AET+1; $i++ ) {
if ( %{$AET[$i]}->{invSlope} != 0 ) {
%{$AET[$i]}->{Xbot} += %{$AET[$i]}->{invSlope};
}
}
} while( $#AET >= 0  and $#ET >= 0 );
}

sub calcOneOverSlope {
my $edge = shift;
my $y = @{$edge}->[0]->gety()-@{$edge}->[1]->gety();
my $x = @{$edge}->[0]->getx()-@{$edge}->[1]->getx();
if ( $y == 0 ) { return undef; }
return $x/$y;
}

sub getHighestY {
my $edges       = shift;
my $edge        = @{$edges}[0];
my $vector      = @{$edge}[0];
my $highest = $vector->gety();

for my $edge (@{$edges}) {
for my $vector (@{$edge}) {
my $y = $vector->gety();
if ( $y > $highest ) {
$highest = $y;
}
}
}
return $highest;
}

sub setPixel {
my ( $pkg, $X, $Y, $color ) = @_;
my $rgb = sprintf "#%03x", $color;
$pkg->{can}->create ( 'rectangle',
$X,   $Y,
$X+1, $Y+1,
-fill => $rgb,
-outline => $rgb
);
}

1;
}
{
package Vector2D;
use strict;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
use overload
"-"    => \&minus,
"+"    => \&plus,
"*"    => \&mult,
"bool" => \&bool,
"=="   => \&equal;




$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT      = ();

sub new  {
my ($pkg,$x,$y) = @_;
bless {
_x => $x,
_y => $y
}, $pkg;
}

sub getx { my $obj = shift; return $obj->{_x}; }
sub gety { my $obj = shift; return $obj->{_y}; }
sub setx { my $obj = shift; my $v = shift; $obj->{_x} = $v; }
sub sety { my $obj = shift; my $v = shift; $obj->{_y} = $v; }

sub getxy {
my $obj = shift;
my @xy = ( $obj->getx(), $obj->gety() );
return @xy;
}

sub plus {
my $u = shift;
my $v = shift;
return new Vector2D (
$u->getx() + $v->getx(),
$u->gety() + $v->gety()
);
}

sub minus {
my $u = shift;
my $v = shift;
return new Vector2D (
$u->getx() - $v->getx(),
$u->gety() - $v->gety()
);
}

sub mult {
my $v = shift;
my $c = shift;
return new Vector2D (
$c * $v->getx(),
$c * $v->gety()
);
}

sub bool { return defined( shift ); }
sub equal {
my $u = shift;
my $v = shift;
return  ( $u->getx() == $v->getx() ) && ( $u->gety() == $v->gety() );
}
sub incr {
my $u = shift;
my $v = shift;
$u->{_x} += $v->{_x};
$u->{_y} += $v->{_y};
return $u;
}

sub decr {
my $u = shift;
my $v = shift;
$u->{_x} -= $v->{_x};
$u->{_y} -= $v->{_y};
return $u;
}

sub scale {
my $v = shift;
my $c = shift;
$v->{_x} *= $c;
$v->{_y} *= $c;
return $v;
}

sub rotate {
my $P = shift; #vector 
my $C = shift; #vector 
my $cosphi = shift;
my $sinphi = shift;
my $dx = $P->{_x} - $C->{_x};
my $dy = $P->{_y} - $C->{_y};
return new Vector2D (
$C->{_x} + $dx * $cosphi - $dy * $sinphi,
$C->{_y} + $dx * $sinphi + $dy * $cosphi
);
}

sub print {
my $v = shift; #vector 
print "( " . $v->getx() . ", " . $v->gety() . ")\n";
}


1;
}
}