I think Tk::Zinc is far superior to the regular canvas, you might want to look at it's easy method for creating curves. A polygon is a curve in Zinc.
Here is a script I had laying around which uses the regular canvas, and some vector methods for generating the polygon.
#!/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, -backgrou
+nd=>'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}->{invSlo
+pe} . "}" ;
}
}
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 th
+e 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() ) ? @{$edg
+e}->[0]->gety() : @{$edge}->[1]->gety() ;
my $Ymax = ( @{$edge}->[0]->gety() >= @{$edge}->[1]->gety() ) ? @{$edg
+e}->[0]->gety() : @{$edge}->[1]->gety() ;
my $Xbot = ( @{$edge}->[0]->gety() < @{$edge}->[1]->gety() ) ? @{$edg
+e}->[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;
}
}
|