perlquestion
rbc
Dear Monks,<BR>
<BR>
I almost have a z-buffer algorithm working for some 3D<BR>
graphics I am doing. But if you run the below script<BR>
you can see I don't have quite worked out correctly.<BR>
<BR>
Please help! I know it looks like a lot of code but<BR>
I suspect the problem is in the <b>sub fillZbuff</b> or<BR>
<b>sub buildET4Zbuff</b> or the <b>sub ProjectLine</b><BR>
<readmore>
<code>
#!/usr/bin/perl -w
use strict;
use Tk;
use Tk::Canvas;
use Getopt::Std;
use Math::Trig;
use Data::Dumper;
use Math::Round qw( nearest_floor nearest_ceil );
my $width = 500;
my $height = 500;
my $screenDist = 1000;
my $background = 'blue';
my $fill = 'yellow';
my $zmin = -10;
my %opts = ();
getopts( 'w:h:b:f:z:', \%opts );
if( $opts{w} ) { $width = $opts{w} ; }
if( $opts{h} ) { $height = $opts{h} ; }
if( $opts{b} ) { $background = $opts{b} ; }
if( $opts{f} ) { $fill = $opts{f} ; }
if( $opts{z} ) { $zmin = $opts{z} ; }
my $pidiv180 = atan(1)/45;
my $top = MainWindow->new();
my $frame = $top->Frame();
my $can = $top->Canvas( -width => $width, -height=> $height, -background=>$background );
#my $rho = -1;
my $rho = 0;
my $theta = 90;
my $phi = 0.0;
my $rotateZ = 0.0;
my $rotateX = 0.0;
my $rotateY = 30.0;
my $TZ = 15;
my $TX = 0;
my $TY = 0;
my $N = 1;
my $colorSide_A = 240;
my $colorSide_B = 3333; # kind of red
my $x_center;
my $y_center;
my $YMAX;
my $per;
my $clipVol;
my $y_max = 1;
my $y_min = -1;
my @ZBUFFER;
sub clear{ $can->delete( 'all' ); }
sub doit {
$x_center = $can->reqwidth()/2.0;
$y_center = $can->reqheight()/2.0;
$YMAX = $can->reqheight();
$per = new Perspective( $rho, $theta*$pidiv180, $phi*$pidiv180 );
$clipVol = new Clip3D( $zmin );
for( my $i=0; $i<$can->reqwidth(); $i++ ) {
for( my $j=0; $j<$can->reqheight(); $j++ ) {
$ZBUFFER[$i][$j] = 9999999;
}
}
my @cube = (
new Vector3D( 1, -1, -1 ), # 0 A
new Vector3D( 1, 1, -1 ), # 1 B
new Vector3D( -1, 1, -1 ), # 2 C
new Vector3D( -1, -1, -1 ), # 3 D
new Vector3D( 1, -1, 1 ), # 4 E
new Vector3D( 1, 1, 1 ), # 5 F
new Vector3D( -1, 1, 1 ), # 6 G
new Vector3D( -1, -1, 1 ) # 7 H
);
my @negative_y_axis = (
new Vector3D( 0, 0, 0.1 ), # 0
new Vector3D( 0, -10, 0.1 ), # 1
);
my @positive_y_axis = (
new Vector3D( 0, 0, 0.1 ), # 0
new Vector3D( 0, 10, 0.1 ), # 1
);
my @negative_x_axis = (
new Vector3D( 0, 0, 0.1 ), # 0
new Vector3D( -10, 0, 0.1 ), # 1
);
my @positive_x_axis = (
new Vector3D( 0, 0, 0.1 ), # 0
new Vector3D( 10, 0, 0.1 ), # 1
);
for( my $i=0; $i<$N; $i++ ) {
foreach my $v ( @cube ) { $v->rotateZ( $rotateZ * $pidiv180 ); }
foreach my $v ( @cube ) { $v->rotateX( $rotateX * $pidiv180 ); }
foreach my $v ( @cube ) { $v->rotateY( $rotateY * $pidiv180 ); }
foreach my $v ( @cube ) { $v->translate( new Vector3D($TX, $TY, $TZ) ); }
my @zero = (
new Vector3D( $cube[0]->getx() + 0.05, $cube[0]->gety() , $cube[0]->getz() ), # 0
new Vector3D( $cube[0]->getx() + 0.1, $cube[0]->gety() , $cube[0]->getz() ), # 1
new Vector3D( $cube[0]->getx() + 0.1, $cube[0]->gety() + 0.1, $cube[0]->getz() ), # 1
new Vector3D( $cube[0]->getx() + 0.05, $cube[0]->gety() + 0.1, $cube[0]->getz() ), # 1
new Vector3D( $cube[0]->getx() + 0.05, $cube[0]->gety() , $cube[0]->getz() ), # 0
);
my @one = (
new Vector3D( $cube[1]->getx() + 0.1, $cube[1]->gety() , $cube[1]->getz() ), # 1
new Vector3D( $cube[1]->getx() + 0.1, $cube[1]->gety() + 0.1, $cube[1]->getz() ), # 1
);
my @two = (
new Vector3D( $cube[2]->getx() - 0.10, $cube[2]->gety() + 0.10, $cube[2]->getz() ), # 1
new Vector3D( $cube[2]->getx() - 0.05, $cube[2]->gety() + 0.10, $cube[2]->getz() ), # 1
new Vector3D( $cube[2]->getx() - 0.05, $cube[2]->gety() + 0.05, $cube[2]->getz() ), # 0
new Vector3D( $cube[2]->getx() - 0.10, $cube[2]->gety() + 0.05, $cube[2]->getz() ), # 0
new Vector3D( $cube[2]->getx() - 0.10, $cube[2]->gety() , $cube[2]->getz() ), # 0
new Vector3D( $cube[2]->getx() - 0.05, $cube[2]->gety() , $cube[2]->getz() ), # 1
);
my @three = (
new Vector3D( $cube[3]->getx() - 0.10, $cube[3]->gety() + 0.10, $cube[3]->getz() ), # 1
new Vector3D( $cube[3]->getx() - 0.05, $cube[3]->gety() + 0.10, $cube[3]->getz() ), # 1
new Vector3D( $cube[3]->getx() - 0.05, $cube[3]->gety() + 0.05, $cube[3]->getz() ), # 0
new Vector3D( $cube[3]->getx() - 0.10, $cube[3]->gety() + 0.05, $cube[3]->getz() ), # 0
new Vector3D( $cube[3]->getx() - 0.05, $cube[3]->gety() + 0.05, $cube[3]->getz() ), # 0
new Vector3D( $cube[3]->getx() - 0.05, $cube[3]->gety() , $cube[3]->getz() ), # 0
new Vector3D( $cube[3]->getx() - 0.10, $cube[3]->gety() , $cube[3]->getz() ), # 1
);
my @four = (
new Vector3D( $cube[4]->getx() + 0.05, $cube[4]->gety() + 0.10, $cube[4]->getz() ), # 1
new Vector3D( $cube[4]->getx() + 0.05, $cube[4]->gety() + 0.05, $cube[4]->getz() ), # 4
new Vector3D( $cube[4]->getx() + 0.10, $cube[4]->gety() + 0.05, $cube[4]->getz() ), # 3
new Vector3D( $cube[4]->getx() + 0.10, $cube[4]->gety() + 0.10, $cube[4]->getz() ), # 2
new Vector3D( $cube[4]->getx() + 0.10, $cube[4]->gety() , $cube[4]->getz() ), # 6
);
my @five = (
new Vector3D( $cube[5]->getx() + 0.10, $cube[5]->gety() + 0.10, $cube[5]->getz() ), # 1
new Vector3D( $cube[5]->getx() + 0.05, $cube[5]->gety() + 0.10, $cube[5]->getz() ), # 1
new Vector3D( $cube[5]->getx() + 0.05, $cube[5]->gety() + 0.05, $cube[5]->getz() ), # 0
new Vector3D( $cube[5]->getx() + 0.10, $cube[5]->gety() + 0.05, $cube[5]->getz() ), # 0
new Vector3D( $cube[5]->getx() + 0.10, $cube[5]->gety() , $cube[5]->getz() ), # 0
new Vector3D( $cube[5]->getx() + 0.05, $cube[5]->gety() , $cube[5]->getz() ), # 1
);
my @six = (
new Vector3D( $cube[6]->getx() - 0.05, $cube[6]->gety() + 0.10, $cube[6]->getz() ), # 1
new Vector3D( $cube[6]->getx() - 0.10, $cube[6]->gety() + 0.10, $cube[6]->getz() ), # 1
new Vector3D( $cube[6]->getx() - 0.10, $cube[6]->gety() + 0.05, $cube[6]->getz() ), # 0
new Vector3D( $cube[6]->getx() - 0.05, $cube[6]->gety() + 0.05, $cube[6]->getz() ), # 0
new Vector3D( $cube[6]->getx() - 0.05, $cube[6]->gety() , $cube[6]->getz() ), # 0
new Vector3D( $cube[6]->getx() - 0.10, $cube[6]->gety() , $cube[6]->getz() ), # 1
new Vector3D( $cube[6]->getx() - 0.10, $cube[6]->gety() + 0.05, $cube[6]->getz() ), # 0
);
my @seven = (
new Vector3D( $cube[7]->getx() - 0.10, $cube[7]->gety() + 0.10, $cube[7]->getz() ), # 1
new Vector3D( $cube[7]->getx() - 0.05, $cube[7]->gety() + 0.10, $cube[7]->getz() ), # 1
new Vector3D( $cube[7]->getx() - 0.05, $cube[7]->gety() , $cube[7]->getz() ), # 0
);
DrawPolygon ( [ $cube[0], $cube[1], $cube[5], $cube[4], $cube[0] ], $colorSide_A ); #side A
DrawPolygon ( [ $cube[4], $cube[5], $cube[6], $cube[7], $cube[4] ], 140 ); #side B
DrawPolygon ( [ $cube[7], $cube[6], $cube[2], $cube[3], $cube[7] ], 901 ); #side C
DrawPolygon ( [ $cube[6], $cube[2], $cube[1], $cube[5], $cube[6] ], 56 ); #side D
DrawPolygon ( [ $cube[0], $cube[4], $cube[7], $cube[3], $cube[0] ], 591 ); #side E
drawShape( \@zero );
drawShape( \@one );
drawShape( \@two );
drawShape( \@three );
drawShape( \@four );
drawShape( \@five );
drawShape( \@six );
drawShape( \@seven );
# drawShape( \@negative_y_axis, 'red' );
# drawShape( \@positive_y_axis, 'white' );
# drawShape( \@negative_x_axis, 'black' );
# drawShape( \@positive_x_axis, 'white' );
} # end for loop
}
sub drawShape {
my $shape = shift; # ref to array of vector3D
my $color = shift || 'red';
my @s = @{$shape};
my $v1 = pop(@s);
while (@s) {
my $v2 = pop(@s);
DrawLine( $v1, $v2, $color ); #, $per, $screenDist, $x_center, $y_center, $clipVol );
$v1 = $v2;
}
}
sub DrawPolygon {
my $points = shift; # ref to array of Vector3Ds
my $color = shift;
my @edges;
my @pts = @{$points};
my $curr = $pts[0];
for ( my $i=1; $i<=$#pts; $i++ ) {
my $next = $pts[$i];
my $ptPair = ProjectLine( $curr, $next );
push( @edges, $ptPair );
$curr = $next;
}
my $polygon = new PolygonZbuffer( \@edges, $can, $color );
$polygon->fillZbuff(\@ZBUFFER);
}
sub ProjectLine {
my $v1 = shift;
my $v2 = shift;
my $color = shift || $fill;
my( $x1, $y1, $x2, $y2, $visible );
my $X1 = $v1->getx();
my $Y1 = $v1->gety();
my $Z1 = $v1->getz();
my $X2 = $v2->getx();
my $Y2 = $v2->gety();
my $Z2 = $v2->getz();
$visible = $clipVol->Clip ( \$X1, \$Y1, \$Z1, \$X2, \$Y2, \$Z2);
if ( $visible == 1 ) {
my $V1 = new Vector3D( $X1, $Y1, $Z1 );
my $V2 = new Vector3D( $X2, $Y2, $Z2 );
$per->perspective( $V1, \$x1, \$y1 );
$per->perspective( $V2, \$x2, \$y2 );
my $A = new Vector2D (
nearest_ceil( 1, $screenDist * $x1 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y1 + $y_center))
);
my $B = new Vector2D (
nearest_ceil( 1, $screenDist * $x2 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y2 + $y_center))
);
#my @AB = ( $A, $B );
my $rec = {
#edge => @AB,
edge => [$A, $B],
dx => $X1 - $X2,
dz => $Z1 - $Z2,
# z => $Z1
z => ( $X1 < $X2 ) ? ($Z1) : ($Z2)
};
return $rec;
}
return undef;
}
sub DrawLine {
my $v1 = shift;
my $v2 = shift;
my $color = shift || $fill;
my( $x1, $y1, $x2, $y2, $visible );
my $X1 = $v1->getx();
my $Y1 = $v1->gety();
my $Z1 = $v1->getz();
my $X2 = $v2->getx();
my $Y2 = $v2->gety();
my $Z2 = $v2->getz();
$visible = $clipVol->Clip ( \$X1, \$Y1, \$Z1, \$X2, \$Y2, \$Z2);
if ( $visible == 1 ) {
my $V1 = new Vector3D( $X1, $Y1, $Z1 );
my $V2 = new Vector3D( $X2, $Y2, $Z2 );
$per->perspective( $V1, \$x1, \$y1 );
$per->perspective( $V2, \$x2, \$y2 );
$can->create( 'line',
$screenDist * $x1 + $x_center,
$YMAX - ($screenDist * $y1 + $y_center),
$screenDist * $x2 + $x_center,
$YMAX - ($screenDist * $y2 + $y_center),
-fill => $color
);
my $A = new Vector2D (
nearest_ceil( 1, $screenDist * $x1 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y1 + $y_center))
);
my $B = new Vector2D (
nearest_ceil( 1, $screenDist * $x2 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y2 + $y_center))
);
my @AB = ( $A, $B );
return @AB;
}
return undef;
}
$can->packAdjust( -side => 'left', -fill => 'both', -delay => 1 );
$frame->pack(
-side => 'left',
-fill => 'y',
-expand => 'y',
-anchor => 'w' );
my $mbutton = $frame->Button(
-relief => "groove",
-text => "Viewing Dist rho = EO " )->pack( anchor => 'w' );
my $mentry = $frame->Entry(
-width => 10,
-textvariable => \$rho)->form(
-left => [$mbutton,0] );
my $nbutton = $frame->Button(
-relief => "groove",
-text => "theta = ")->form(
-top => [$mbutton,0] );
my $nentry = $frame->Entry(
-width => 10,
-textvariable => \$theta)->form(
-left => [$nbutton,0],
-top => [$mbutton,0] );
my $phibutton = $frame->Button(
-relief => "groove",
-text => "phi = ",
)->form( -top => [$nbutton,0] );
my $phientry = $frame->Entry(
-width => 10,
-textvariable => \$phi) ->form(
-left => [$phibutton,0],
-top => [$nbutton,0] );
my $rotZbutton = $frame->Button(
-relief => "groove",
-text => "rotZ = ",
)->form( -top => [$phibutton,0] );
my $rotZentry = $frame->Entry(
-width => 10,
-textvariable => \$rotateZ) ->form(
-left => [$rotZbutton,0],
-top => [$phibutton,0] );
my $rotXbutton = $frame->Button(
-relief => "groove",
-text => "rotX = ",
)->form( -top => [$rotZbutton,0] );
my $rotXentry = $frame->Entry(
-width => 10,
-textvariable => \$rotateX) ->form(
-left => [$rotXbutton,0],
-top => [$rotZbutton,0] );
my $rotYbutton = $frame->Button(
-relief => "groove",
-text => "rotY = ",
)->form( -top => [$rotXbutton,0] );
my $rotYentry = $frame->Entry(
-width => 10,
-textvariable => \$rotateY) ->form(
-left => [$rotYbutton,0],
-top => [$rotXbutton,0] );
#####
my $TZbutton = $frame->Button(
-relief => "groove",
-text => "TX = ",
)->form( -top => [$rotYbutton,0] );
my $TZentry = $frame->Entry(
-width => 10,
-textvariable => \$TX) ->form(
-left => [$TZbutton,0],
-top => [$rotYbutton,0] );
my $TXbutton = $frame->Button(
-relief => "groove",
-text => "TY = ",
)->form( -top => [$TZbutton,0] );
my $TXentry = $frame->Entry(
-width => 10,
-textvariable => \$TY) ->form(
-left => [$TXbutton,0],
-top => [$TZbutton,0] );
my $TYbutton = $frame->Button(
-relief => "groove",
-text => "TZ = ",
)->form( -top => [$TXbutton,0] );
my $TYentry = $frame->Entry(
-width => 10,
-textvariable => \$TZ) ->form(
-left => [$TYbutton,0],
-top => [$TXbutton,0] );
my $dist_button = $frame->Button(
-relief => "groove",
-text => "Dist = ",
)->form( -top => [$TYbutton,0] );
my $dist_entry = $frame->Entry(
-width => 10,
-textvariable => \$screenDist) ->form(
-left => [$dist_button,0],
-top => [$TYbutton,0] );
my $N_button = $frame->Button(
-relief => "groove",
-text => "N = ",
)->form( -top => [$dist_button,0] );
my $N_entry = $frame->Entry(
-width => 10,
-textvariable => \$N) ->form(
-left => [$N_button,0],
-top => [$dist_button,0] );
my $zmin_button = $frame->Button(
-relief => "groove",
-text => "zmin = ",
)->form( -top => [$N_button,0] );
my $zmin_entry = $frame->Entry(
-width => 10,
-textvariable => \$zmin) ->form(
-left => [$zmin_button,0],
-top => [$N_button,0] );
my $doButton = $frame->Button(
-relief => "groove",
-text => "Draw",
-command => \&doit )->form(
-top => [$zmin_button,0] );
my $clearButton = $frame->Button(
-relief => "groove",
-text => "Clear",
-command => \&clear )->form(
-top => [$zmin_button,0],
-left => [$doButton,0] );
my $colorAButton = $frame->Button(
-relief => "groove",
-text => "Color Side A = ",
)->form( -top => [$clearButton,0] );
my $colorAEntry = $frame->Entry(
-width => 10,
-textvariable => \$colorSide_A) ->form(
-left => [$colorAButton,0],
-top => [$clearButton,0] );
MainLoop;
BEGIN {
#include module Vector3D
{
package Vector3D;
use strict;
use overload
"-" => \&minus,
"+" => \&plus,
"*" => \&mult;
sub new {
my ($pkg,$x,$y,$z) = @_;
bless {
_x => $x,
_y => $y,
_z => $z
}, $pkg;
}
sub getx { my $obj = shift; return $obj->{_x}; }
sub gety { my $obj = shift; return $obj->{_y}; }
sub getz { my $obj = shift; return $obj->{_z}; }
sub getxyz {
my $obj = shift;
my @xyz = ( $obj->getx(), $obj->gety(), $obj->getz() );
return @xyz;
}
sub setx { my $obj = shift; $obj->{_x} = shift; }
sub sety { my $obj = shift; $obj->{_y} = shift; }
sub setz { my $obj = shift; $obj->{_z} = shift; }
sub setxyz {
my $obj = shift;
$obj->setx(shift);
$obj->sety(shift);
$obj->setz(shift);
}
sub plus {
my $u = shift;
my $v = shift;
return new Vector3D (
$u->getx() + $v->getx(),
$u->gety() + $v->gety(),
$u->getz() + $v->getz()
);
}
sub minus {
my $u = shift;
my $v = shift;
return new Vector3D (
$u->getx() - $v->getx(),
$u->gety() - $v->gety(),
$u->getz() - $v->getz()
);
}
sub mult {
my $v = shift;
my $c = shift;
return new Vector3D (
$c * $v->getx(),
$c * $v->gety(),
$c * $v->getz()
);
}
sub incr {
my $u = shift;
my $v = shift;
$u->{_x} += $v->{_x};
$u->{_y} += $v->{_y};
$u->{_z} += $v->{_z};
return $u;
}
sub decr {
my $u = shift;
my $v = shift;
$u->{_x} -= $v->{_x};
$u->{_y} -= $v->{_y};
$u->{_z} -= $v->{_z};
return $u;
}
sub scale {
my $v = shift;
my $c = shift;
$v->{_x} *= $c;
$v->{_y} *= $c;
$v->{_z} *= $c;
return $v;
}
sub translate {
my $u = shift;
my $v = shift;
$u->{_x} += $v->getx();
$u->{_y} += $v->gety();
$u->{_z} += $v->getz();
}
sub dotproduct {
my $obj = shift; #vector
my $b = shift; #vector
return $obj->getx() * $b->getx() +
$obj->gety() * $b->gety() +
$obj->getz() * $b->getz();
}
sub abs {
my $obj = shift; #vector
return sqrt ( $obj->getx() * $obj->getx()+
$obj->gety() * $obj->gety()+
$obj->getz() * $obj->getz());
}
sub crossproduct {
my $obj = shift; #vector
my $b = shift; #vector
return new Vector3D(
$obj->gety() * $b->getz() - $obj->getz() * $b->gety(),
$obj->getz() * $b->getx() - $obj->getx() * $b->getz(),
$obj->getx() * $b->gety() - $obj->gety() * $b->getx()
);
}
sub rotateZ {
my $P = shift; #vector
my $phi = shift;
my $cosphi = cos( $phi );
my $sinphi = sin( $phi );
my $dx = $P->{_x};
my $dy = $P->{_y};
$P->setx( $dx * $cosphi - $dy * $sinphi );
$P->sety( $dx * $sinphi + $dy * $cosphi );
}
sub rotateY {
my $P = shift; #vector
my $phi = shift;
my $cosphi = cos( $phi );
my $sinphi = sin( $phi );
my $dx = $P->{_x};
my $dz = $P->{_z};
$P->setx( $dx * $cosphi - $dz * $sinphi );
$P->setz( $dx * $sinphi + $dz * $cosphi );
}
sub rotateX {
my $P = shift; #vector
my $phi = shift;
my $cosphi = cos( $phi );
my $sinphi = sin( $phi );
my $dy = $P->{_y};
my $dz = $P->{_z};
$P->sety( $dy * $cosphi - $dz * $sinphi );
$P->setz( $dy * $sinphi + $dz * $cosphi );
}
sub print {
my $v = shift; #vector
print "( " . $v->getx() .
", " . $v->gety() .
", " . $v->getz() . ")\n";
}
1;
} #end package Vector3D
#include module Vector2D
{
package Vector2D;
#####################################################
### 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 overload
"-" => \&minus,
"+" => \&plus,
"*" => \&mult,
"bool" => \&bool;
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 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;
} #end modeult Vector2D
# include Perspective module
{
package Perspective;
use strict;
use Math::Trig;
sub new {
my ($pkg,$rho,$theta,$phi) = @_;
bless {
_rho => $rho,
_theta => $theta,
_phi => $phi,
_v11 => ( -sin( $theta ) ),
_v12 => ( -cos( $phi ) * cos( $theta ) ),
_v13 => ( -sin( $phi ) * cos( $theta ) ),
_v21 => ( cos( $theta ) ),
_v22 => ( -cos( $phi ) * sin( $theta ) ),
_v23 => ( -sin( $phi ) * sin( $theta ) ),
_v32 => ( sin( $phi ) ),
_v33 => ( -cos( $phi ) ),
_v43 => ( $rho )
}, $pkg;
}
sub getrho { my $obj = shift; return $obj->{_rho}; }
sub gettheta { my $obj = shift; return $obj->{_theta}; }
sub getphi { my $obj = shift; return $obj->{_phi}; }
sub getv11 { my $obj = shift; return $obj->{_v11}; }
sub getv12 { my $obj = shift; return $obj->{_v12}; }
sub getv13 { my $obj = shift; return $obj->{_v13}; }
sub getv21 { my $obj = shift; return $obj->{_v21}; }
sub getv22 { my $obj = shift; return $obj->{_v22}; }
sub getv23 { my $obj = shift; return $obj->{_v23}; }
sub getv32 { my $obj = shift; return $obj->{_v32}; }
sub getv33 { my $obj = shift; return $obj->{_v33}; }
sub getv43 { my $obj = shift; return $obj->{_v43}; }
sub setrho { my $obj = shift; $obj->{_rho} = shift; }
sub settheta { my $obj = shift; $obj->{_theta} = shift; }
sub setphi { my $obj = shift; $obj->{_phi} = shift; }
sub setv11 { my $obj = shift; $obj->{_v11} = shift; }
sub setv12 { my $obj = shift; $obj->{_v12} = shift; }
sub setv13 { my $obj = shift; $obj->{_v13} = shift; }
sub setv21 { my $obj = shift; $obj->{_v21} = shift; }
sub setv22 { my $obj = shift; $obj->{_v22} = shift; }
sub setv23 { my $obj = shift; $obj->{_v23} = shift; }
sub setv32 { my $obj = shift; $obj->{_v32} = shift; }
sub setv33 { my $obj = shift; $obj->{_v33} = shift; }
sub setv43 { my $obj = shift; $obj->{_v43} = shift; }
sub eyecoord {
my $obj = shift;
my $pw = shift;
my $pe = shift;
my $x = $pw->getx();
my $y = $pw->gety();
my $z = $pw->getz();
my $v11 = $obj->getv11();
my $v12 = $obj->getv12();
my $v13 = $obj->getv13();
my $v21 = $obj->getv21();
my $v22 = $obj->getv22();
my $v23 = $obj->getv23();
my $v32 = $obj->getv32();
my $v33 = $obj->getv33();
my $v43 = $obj->getv43();
$pe->setx( $v11 * $x + $v21 * $y );
$pe->sety( $v12 * $x + $v22 * $y + $v32 * $z);
$pe->setz( $v13 * $x + $v23 * $y + $v33 * $z + $v43);
}
sub perspective {
my $obj = shift;
my $p = shift;
my $refpx = shift;
my $refpy = shift;
my $pe = new Vector3D( 0.0, 0.0, 0.0 );
$obj->eyecoord ( $p, $pe );
$$refpx = $pe->getx() / (1E-7 + $pe->getz());
$$refpy = $pe->gety() / (1E-7 + $pe->getz());
}
1;
} #end Perspective
# include Clip3D;
{
package Clip3D;
#####################################################
### 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 Tk;
sub new {
my ($pkg,$zmin,$tag) = @_;
bless {
_zmin => $zmin,
_tag => $tag || 'CLIPVOL'
}, $pkg;
}
sub setzmin {
my $obj = shift;
my $zmin = shift;
$obj->{_zmin} = $zmin;
}
sub settag {
my $obj = shift;
my $tag = shift;
$obj->{_tag} = $tag;
}
sub getzmin { my $obj = shift; return $obj->{_zmin}; }
sub gettag { my $obj = shift; return $obj->{_tag}; }
sub Clip {
# refs to scalars
my $pkg = shift;
my $x0 = shift;
my $y0 = shift;
my $z0 = shift;
my $x1 = shift;
my $y1 = shift;
my $z1 = shift;
#scalar
my $zmin = $pkg->getzmin();
my $accept = 0; # assume that line is not visiable
my $tmin = 0;
my $tmax = 1;
my $dx = $$x1 - $$x0;
my $dz = $$z1 - $$z0;
if ( clipT( $dx+$dz, -$$x0-$$z0, \$tmin, \$tmax ) ) { # Right side
if ( clipT( -$dx+$dz, $$x0-$$z0, \$tmin, \$tmax ) ) { # Left side
my $dy = $$y1 - $$y0;
if ( clipT( -$dy+$dz, $$y0-$$z0, \$tmin, \$tmax ) ) { # Bottom side
if ( clipT( $dy+$dz, -$$y0-$$z0, \$tmin, \$tmax ) ) { # Top side
# part of line is in -z <= x <= z, -z <= y <= z
if ( clipT( $dz, -$$z0 + $zmin, \$tmin, \$tmax ) ) { # Front
if ( clipT( -$dz, -$$z0-1, \$tmin, \$tmax ) ) { # Back
# part of line is visible in -z <= x <= z, -z <= y <= z, -1 <= x <= $zmin
$accept = 1;
# If end pt 1 (t=1) is not in region, compute intersection
if ( $tmax < 1 ) {
$$x1 = $$x0 + $tmax * $dx;
$$y1 = $$y0 + $tmax * $dy;
$$z1 = $$z0 + $tmax * $dz;
}
# If end pt 0 (t=0) is not in region, compute intersection
if ( $tmin > 0 ) {
$$x0 = $$x0 + $tmin * $dx;
$$y0 = $$y0 + $tmin * $dy;
$$z0 = $$z0 + $tmin * $dz;
}
}
}
}
}
}
}
return $accept;
}
###################################################################
###
### sub clipT is used by the sub clipLine defined in this
### module. clipT is based on pseudo code presented in
### Foley, van Dam, Feiner, and Hughes's book "Computer Graphics:
### Principles and Practive" 2nd Edition pages on page 122. The
### following comment is taken almost verbatum from that book.
###
### clipT computes a new value of tE or tL for an interior
### intersection of a line segment and an edge. Parameter
### demon is -dotProduct(Ni, D), which reduces to
### +/- deltaX, deltaY for upright rectangles; its sign determines
### whether the intersection is PE or PL. Parameter num is
### dotProduct( Ni, Po-Pei) for a particular edge/line
### combination, which reduces to directed horizontal and
### vertical distance from Po to an edg; its sign determines
### visibility of Po and is used to trivially reject, false is
### returned; if it cannot be, true is returned and the value
### of tE or tL is adjusted, if needed, for the portian of the
### segment that is inside the edge.
###
###################################################################
sub clipT {
my $denom = shift;
my $num = shift;
my $tE = shift; # ref to scalar
my $tL = shift; # ref to scalar
my $t;
my $accept = 1; # 1 implie TRUE. 0 implies FALSE
if ( $denom > 0 ) {
$t = $num/$denom;
if ( $t > $$tL ) {
$accept = 0;
} elsif ( $t > $$tE ) {
$$tE = $t;
}
} elsif ( $denom < 0 ) {
$t = $num/$denom;
if ( $t < $$tE ) {
$accept = 0;
} elsif ( $t < $$tL ) {
$$tL = $t;
}
} else {
if ( $num > 0 ) {
$accept = 0;
}
}
return $accept;
}
1;
} # end Clip3D;
#include PolygonZbuffer;
{
package PolygonZbuffer;
use strict;
use Exporter;
#use Vector3D;
use Math::Round qw( nearest_floor nearest_ceil );
use Tk;
use Tk::Canvas;
use Data::Dumper;
sub new {
my ($pkg, $edges, $canvas, $color) = @_;
my $highestY = getHighestY($edges);
bless {
edges => $edges, # ref to array of edge info hash
ET => undef, # edge table
highestY => $highestY,
can => $canvas, #Tk canvas
color => $color
}, $pkg;
}
sub print {
my $pkg = shift;
foreach my $e ( @{$pkg->{edges}} ) {
@{$e}->[0]->print();
@{$e}->[1]->print();
}
}
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 buildET4Zbuff {
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 $e (@{$pkg->{edges}}) {
my $y = ( $e->{edge}->[0]->gety() < $e->{edge}->[1]->gety() ) ? $e->{edge}->[0]->gety() : $e->{edge}->[1]->gety() ;
my $Ymax = ( $e->{edge}->[0]->gety() >= $e->{edge}->[1]->gety() ) ? $e->{edge}->[0]->gety() : $e->{edge}->[1]->gety() ;
my $z = $e->{z};
my $Xbot = ( $e->{edge}->[0]->gety() < $e->{edge}->[1]->gety() ) ? $e->{edge}->[0]->getx() : $e->{edge}->[1]->getx() ;
my $dz = $e->{dz};
my $dx = $e->{dx};
my $invSlope = &calcOneOverSlope($e);
my $rec = {
Ymax => $Ymax,
Xbot => $Xbot,
invSlope => $invSlope,
dz => $dz,
dx => $dx,
z => $z,
};
push( @{$pkg->{ET}[$y]}, $rec );
}
my $highestY = $pkg->{highestY};
for my $i (0..$highestY-1) { if ( $pkg->{ET}[$i] ) { return $i; } }
}
sub fillZbuff {
my $pkg = shift;
my $zbuffer = shift; # ref to 2D array
my $color = $pkg->{color};
my $y = $pkg->buildET4Zbuff();
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++];
my $left;
my $right;
if ( $x2 ) {
$last = $x2;
$X1 = nearest_ceil(1,%{$x1}->{Xbot});
$X2 = nearest_floor(1,%{$x2}->{Xbot});
$left = $x1;
$right = $x2;
} else {
$X1 = nearest_ceil(1,%{$last}->{Xbot});
$X2 = nearest_floor(1,%{$x1}->{Xbot});
$left = $last;
$right = $x1;
}
# my $z = %{$left}->{z};
my $z = nearest_ceil( 1, %{$left}->{z} );
for my $x ( $X1..$X2 ) {
#$z += %{$left}->{dz}/ (%{$left}->{dx} + 1E-7) ;
#$z += %{$left}->{dz};
$z += nearest_ceil( 1, %{$left}->{dz} );
if( $z <= @{$zbuffer}->[$x]->[$y] ) {
$pkg->setPixel( $x, $y, $color );
@{$zbuffer}->[$x]->[$y] = $z;
}
}
}
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 $e = shift;
my $y = $e->{edge}->[0]->gety() - $e->{edge}->[1]->gety();
my $x = $e->{edge}->[0]->getx() - $e->{edge}->[1]->getx();
if ( $y == 0 ) { return undef; }
return $x/$y;
}
sub getHighestY {
my $edges = shift;
#print Dumper( $edges );
my $highest = @{$edges}->[0]->{edge}->[0]->gety();
for my $edge (@{$edges}) {
for my $vector (@{$edge->{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;
}}
</code>