The modified code.
#!/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 Tk;
use Tk::Canvas;
use Getopt::Std;
use Math::Trig;
use Math::Round qw( nearest_floor nearest_ceil );
my %opts = ();
getopts( 'w:h:b:f:z:', \%opts );
my $width = $opts{w} || 500;
my $height = $opts{h} || 500;
my $screenDist = 1000;
my $background = $opts{b} || 'black';
my $fill = $opts{f} || 'yellow';
my $zmin = $opts{z} || -10;
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 = 0;
my $theta = 90;
my $phi = 0.0;
my $rotateZ = 0.0;
my $rotateX = -20.0;
my $rotateY = 30.0;
my $TZ = 10;
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; $#ZBUFFER = $can->reqwidth();
sub clear{ $can->delete( 'all' ); }
sub doit {
print scalar localtime, $/;
$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 );
@$_ = (9999999)x $can->reqheight() for @ZBUFFER;
my @cube = (
new Vector3D( 1, -1, -1, "Z" ), # 0 A
new Vector3D( 1, 1, -1, "1"), # 1 B
new Vector3D( -1, 1, -1, "2"), # 2 C
new Vector3D( -1, -1, -1, "3"), # 3 D
new Vector3D( 1, -1, 1, "4"), # 4 E
new Vector3D( 1, 1, 1, "5"), # 5 F
new Vector3D( -1, 1, 1, "6"), # 6 G
new Vector3D( -1, -1, 1, "7") # 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(1 .. $N) {
my ($rx, $ry, $rz) = map{ $_ * $pidiv180 } $rotateX, $rotateY,
+ $rotateZ;
for (@cube) {
$_->rotateZ( $rz );
$_->rotateX( $rx );
$_->rotateY( $ry );
$_->translate( new Vector3D($TX, $TY, $TZ, "TRANS" ) );
}
my ($x, $y, $z) = $cube[0]->getxyz();
my @zero = (
new Vector3D( $x + 0.05, $y , $z ), # 0
new Vector3D( $x + 0.1, $y , $z ), # 1
new Vector3D( $x + 0.1, $y + 0.1, $z ), # 1
new Vector3D( $x + 0.05, $y + 0.1, $z ), # 1
new Vector3D( $x + 0.05, $y , $z ), # 0
);
($x, $y, $z) = $cube[1]->getxyz();
my @one = (
new Vector3D( $x + 0.1, $y , $z ), # 1
new Vector3D( $x + 0.1, $y + 0.1, $z ), # 1
);
($x, $y, $z) = $cube[2]->getxyz();
my @two = (
new Vector3D( $x - 0.10, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.10, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.10, $y , $z ), # 0
new Vector3D( $x - 0.05, $y , $z ), # 1
);
($x, $y, $z) = $cube[3]->getxyz();
my @three = (
new Vector3D( $x - 0.10, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.10, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.05, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.05, $y , $z ), # 0
new Vector3D( $x - 0.10, $y , $z ), # 1
);
($x, $y, $z) = $cube[4]->getxyz();
my @four = (
new Vector3D( $x + 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x + 0.05, $y + 0.05, $z ), # 4
new Vector3D( $x + 0.10, $y + 0.05, $z ), # 3
new Vector3D( $x + 0.10, $y + 0.10, $z ), # 2
new Vector3D( $x + 0.10, $y , $z ), # 6
);
($x, $y, $z) = $cube[5]->getxyz();
my @five = (
new Vector3D( $x + 0.10, $y + 0.10, $z ), # 1
new Vector3D( $x + 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x + 0.05, $y + 0.05, $z ), # 0
new Vector3D( $x + 0.10, $y + 0.05, $z ), # 0
new Vector3D( $x + 0.10, $y , $z ), # 0
new Vector3D( $x + 0.05, $y , $z ), # 1
);
($x, $y, $z) = $cube[6]->getxyz();
my @six = (
new Vector3D( $x - 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.10, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.10, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.05, $y + 0.05, $z ), # 0
new Vector3D( $x - 0.05, $y , $z ), # 0
new Vector3D( $x - 0.10, $y , $z ), # 1
new Vector3D( $x - 0.10, $y + 0.05, $z ), # 0
);
($x, $y, $z) = $cube[7]->getxyz();
my @seven = (
new Vector3D( $x - 0.10, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y + 0.10, $z ), # 1
new Vector3D( $x - 0.05, $y , $z ), # 0
);
### This will do the zbuffer stuff
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
### This does wireframe
DrawLine( $cube[0], $cube[1], 'yellow' );
DrawLine( $cube[1], $cube[2], 'yellow' );
DrawLine( $cube[2], $cube[3], 'yellow' );
DrawLine( $cube[3], $cube[0], 'yellow' );
DrawLine( $cube[0], $cube[4], 'yellow' );
DrawLine( $cube[4], $cube[5], 'yellow' );
DrawLine( $cube[5], $cube[1], 'yellow' );
DrawLine( $cube[5], $cube[6], 'yellow' );
DrawLine( $cube[6], $cube[2], 'yellow' );
DrawLine( $cube[6], $cube[7], 'yellow' );
DrawLine( $cube[7], $cube[3], 'yellow' );
DrawLine( $cube[7], $cube[4], 'yellow' );
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
print scalar localtime, $/;
}
use constant SHAPE => 0;
use constant COLOR => 1;
sub drawShape {
DrawLine( $_[SHAPE]->[$_-1], $_[SHAPE]->[$_], $_[COLOR]||'red' ) f
+or 1 .. $#{$_[SHAPE]};
}
use constant POINTS => 0;
sub DrawPolygon {
my @edges;
push @edges, ProjectLine( $_[POINTS]->[$_-1], $_[POINTS]->[$_] ) f
+or 1 .. $#{$_[POINTS]};
my $polygon = new PolygonZbuffer( \@edges, $can, $_[COLOR] );
$polygon->fillZbuff(\@ZBUFFER);
}
use constant V1 => 0;
use constant V2 => 1;
sub ProjectLine {
my( $x1, $y1, $x2, $y2 );
my ($X1, $Y1, $Z1) = $_[V1]->getxyz();
my ($X2, $Y2, $Z2) = $_[V2]->getxyz();
if ( $clipVol->Clip ( \$X1, \$Y1, \$Z1, \$X2, \$Y2, \$Z2) ) {
my $V1 = new Vector3D( $X1, $Y1, $Z1, $_[V1]->{name} );
my $V2 = new Vector3D( $X2, $Y2, $Z2, $_[V2]->{name} );
$per->perspective( $V1, \$x1, \$y1 );
$per->perspective( $V2, \$x2, \$y2 );
return {
edge =>[
new Vector2D (
nearest_ceil( 1, $screenDist * $x1 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y1 + $y_
+center))
),
new Vector2D (
nearest_ceil( 1, $screenDist * $x2 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y2 + $y_
+center))
)
],
edge3D => [$V1, $V2],
z => ( $Y1 < $Y2 ) ? ($Z1) : ($Z2),
};
}
return undef;
}
use constant COLOR2 => 2;
sub DrawLine {
my( $x1, $y1, $x2, $y2 );
my ($X1, $Y1, $Z1) = $_[V1]->getxyz();
my ($X2, $Y2, $Z2) = $_[V2]->getxyz();
if ( $clipVol->Clip ( \$X1, \$Y1, \$Z1, \$X2, \$Y2, \$Z2) ) {
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 => $_[COLOR2]
);
return (
new Vector2D (
nearest_ceil( 1, $screenDist * $x1 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y1 + $y_cent
+er))
),
new Vector2D (
nearest_ceil( 1, $screenDist * $x2 + $x_center ),
nearest_floor( 1, $YMAX - ($screenDist * $y2 + $y_cent
+er))
),
)
}
}
###
### Set up the GUI
###
$can->packAdjust( -side => 'left', -fill => 'both', -delay => 1 );
$frame->pack( -side => 'left', -fill => 'y', -expand => 'y', -anch
+or => 'w' );
my $rotZbutton = $frame->Button( -relief => "groove", -text => "rotZ =
+ ", )->pack( anchor => 'w' );
my $rotZentry = $frame->Entry ( -width => 10, -textvariable => \$rot
+ateZ)->form( -left => [$rotZbutton,0] );
my $rotXbutton = $frame->Button( -relief => "groove", -text => "rotX =
+ ", )->form( -top => [$rotZbutton,0] );
my $rotXentry = $frame->Entry ( -width => 10, -textvariable => \$rot
+ateX)
->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 => \$rota
+teY)
->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 $N_button = $frame->Button( -relief => "groove", -text => "N = ", )
+->form( -top => [$TYbutton,0] );
my $N_entry = $frame->Entry( -width => 10, -textvariable => \$N)
->form( -left => [$N_button,0], -top => [$TYbutton,0] );
my $zmin_button = $frame->Button( -relief => "groove", -text => "zmin
+= ", )->form( -top => [$TYbutton,0] );
my $zmin_entry = $frame->Entry( -width => 10, -textvariable => \$z
+min)
->form( -left => [$zmin_button,0], -top => [$TYbutton,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] )
+;
MainLoop;
#####################################################################
### Stick on Perl Modules
#####################################################################
BEGIN {
#include module Vector3D
{
package Vector3D;
use strict;
use constant X => 0;
use constant Y => 1;
use constant Z => 2;
use overload
"-" => \&minus,
"+" => \&plus,
"*" => \&mult,
"==" => \&equal,
"!=" => \¬Equal;
use constant NAME => 3;
sub new {
my $pkg = shift;
bless {
_x => $_[X],
_y => $_[Y],
_z => $_[Z],
name => $_[NAME] || "Unnamed"
}, $pkg;
}
sub equal {
return (
$_[X]->getx() == $_[Y]->getx() and
$_[X]->gety() == $_[Y]->gety() and
$_[X]->getz() == $_[Y]->getz()
);
}
sub notEqual {
return !equal( $_[X], $_[Y] );
}
use constant OBJ => 0;
use constant VALUE => 1;
sub getx { $_[OBJ]->{_x}; }
sub gety { $_[OBJ]->{_y}; }
sub getz { $_[OBJ]->{_z}; }
sub getxyz {
( $_[OBJ]->getx(), $_[OBJ]->gety(), $_[OBJ]->getz() );
}
sub setx { $_[OBJ]->{_x} = $_[VALUE]; }
sub sety { $_[OBJ]->{_y} = $_[VALUE]; }
sub setz { $_[OBJ]->{_z} = $_[VALUE]; }
sub setxyz {
$_[OBJ]->setx($_[VALUE]);
$_[OBJ]->sety($_[VALUE]);
$_[OBJ]->setz($_[VALUE]);
}
sub plus {
return new Vector3D (
$_[X]->getx() + $_[Y]->getx(),
$_[X]->gety() + $_[Y]->gety(),
$_[X]->getz() + $_[Y]->getz()
);
}
sub minus {
return new Vector3D (
$_[X]->getx() - $_[Y]->getx(),
$_[X]->gety() - $_[Y]->gety(),
$_[X]->getz() - $_[Y]->getz()
);
}
use constant SCALE => 1;
sub mult {
return new Vector3D (
$_[SCALE] * $_[Y]->getx(),
$_[SCALE] * $_[Y]->gety(),
$_[SCALE] * $_[Y]->getz()
);
}
sub incr {
$_[X]->{_x} += $_[Y]->{_x};
$_[X]->{_y} += $_[Y]->{_y};
$_[X]->{_z} += $_[Y]->{_z};
return $_[X];
}
sub decr {
$_[X]->{_x} -= $_[Y]->{_x};
$_[X]->{_y} -= $_[Y]->{_y};
$_[X]->{_z} -= $_[Y]->{_z};
return $_[X];
}
sub scale {
$_[Y]->{_x} *= $_[SCALE];
$_[Y]->{_y} *= $_[SCALE];
$_[Y]->{_z} *= $_[SCALE];
return $_[Y];
}
sub translate {
$_[X]->{_x} += $_[Y]->getx();
$_[X]->{_y} += $_[Y]->gety();
$_[X]->{_z} += $_[Y]->getz();
}
use constant VECTOR1 => 0;
use constant VECTOR2 => 1;
sub dotproduct {
return $_[VECTOR1]->getx() * $_[VECTOR2]->getx() +
$_[VECTOR1]->gety() * $_[VECTOR2]->gety() +
$_[VECTOR1]->getz() * $_[VECTOR2]->getz();
}
sub abs {
return sqrt ( $_[VECTOR1]->getx() * $_[VECTOR1]->getx()+
$_[VECTOR1]->gety() * $_[VECTOR1]->gety()+
$_[VECTOR1]->getz() * $_[VECTOR1]->getz());
}
sub crossproduct {
return new Vector3D(
$_[VECTOR1]->gety() * $_[VECTOR2]->getz() - $_[VECTOR1]->getz(
+) * $_[VECTOR2]->gety(),
$_[VECTOR1]->getz() * $_[VECTOR2]->getx() - $_[VECTOR1]->getx(
+) * $_[VECTOR2]->getz(),
$_[VECTOR1]->getx() * $_[VECTOR2]->gety() - $_[VECTOR1]->gety(
+) * $_[VECTOR2]->getx(),
$_[VECTOR1]->{name}
);
}
# Following 3 subs updated to correct error introduced.
use constant PHI => 1;
sub rotateZ {
my $cosphi = cos( $_[PHI] );
my $sinphi = sin( $_[PHI] );
my $dx = $_[VECTOR1]->{_x};
my $dy = $_[VECTOR1]->{_y};
$_[VECTOR1]->setx( $dx * $cosphi - $dy * $sinphi );
$_[VECTOR1]->sety( $dx * $sinphi + $dy * $cosphi );
}
sub rotateY {
my $cosphi = cos( $_[PHI] );
my $sinphi = sin( $_[PHI] );
my $dx = $_[VECTOR1]->{_x};
my $dz = $_[VECTOR1]->{_z};
$_[VECTOR1]->setx( $dx * $cosphi - $dz * $sinphi );
$_[VECTOR1]->setz( $dx * $sinphi + $dz * $cosphi );
}
sub rotateX {
my $cosphi = cos( $_[PHI] );
my $sinphi = sin( $_[PHI] );
my $dy = $_[VECTOR1]->{_y};
my $dz = $_[VECTOR1]->{_z};
$_[VECTOR1]->sety( $dy * $cosphi - $dz * $sinphi );
$_[VECTOR1]->setz( $dy * $sinphi + $dz * $cosphi );
}
sub print {
print "( " . $_[VECTOR1]->getx() .
", " . $_[VECTOR1]->gety() .
", " . $_[VECTOR1]->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 ;
use constant X => 0;
use constant Y => 1;
sub new {
my $pkg = shift;
bless {
_x => $_[X],
_y => $_[Y]
}, $pkg;
}
use constant V2D => 0;
use constant VALUE => 1;
sub getx { $_[V2D]->{_x}; }
sub gety { $_[V2D]->{_y}; }
sub setx { $_[V2D]->{_x} = $_[VALUE]; }
sub sety { $_[V2D]->{_y} = $_[VALUE]; }
sub getxy {
( $_[V2D]->getx(), $_[V2D]->gety() );
}
use constant VECTOR1 => 0;
use constant VECTOR2 => 1;
use constant SCALE => 1;
sub plus {
return new Vector2D (
$_[VECTOR1]->getx() + $_[VECTOR2]->getx(),
$_[VECTOR1]->gety() + $_[VECTOR2]->gety()
);
}
sub minus {
return new Vector2D (
$_[VECTOR1]->getx() - $_[VECTOR2]->getx(),
$_[VECTOR1]->gety() - $_[VECTOR2]->gety()
);
}
sub mult {
return new Vector2D (
$_[SCALE] * $_[VECTOR2]->getx(),
$_[SCALE] * $_[VECTOR2]->gety()
);
}
sub bool { return defined( shift ); }
sub incr {
$_[VECTOR1]->{_x} += $_[VECTOR2]->{_x};
$_[VECTOR1]->{_y} += $_[VECTOR2]->{_y};
return $_[VECTOR1];
}
sub decr {
$_[VECTOR1]->{_x} -= $_[VECTOR2]->{_x};
$_[VECTOR1]->{_y} -= $_[VECTOR2]->{_y};
return $_[VECTOR1];
}
sub scale {
$_[VECTOR2]->{_x} *= $_[SCALE];
$_[VECTOR2]->{_y} *= $_[SCALE];
return $_[VECTOR2];
}
use constant COSPHI => 2;
use constant SINPHI => 3;
sub rotate {
my $dx = $_[VECTOR1]->{_x} - $_[VECTOR2]->{_x};
my $dy = $_[VECTOR1]->{_y} - $_[VECTOR2]->{_y};
return new Vector2D (
$_[VECTOR2]->{_x} + $dx * $_[COSPHI] - $dy * $_[SINPHI],
$_[VECTOR2]->{_y} + $dx * $_[SINPHI] + $dy * $_[COSPHI]
);
}
sub print {
print "( " . $_[VECTOR1]->getx() . ", " . $_[VECTOR1]->gety() . ")
+\n";
}
1;
} #end modeult Vector2D
# include Perspective module
{
package Perspective;
use strict;
use Math::Trig;
use constant RHO => 0;
use constant THETA => 1;
use constant PHI => 2;
sub new {
my $pkg = shift;
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;
}
use constant OBJ => 0;
use constant VALUE => 1;
sub getrho { $_[OBJ]->{_rho}; }
sub gettheta { $_[OBJ]->{_theta}; }
sub getphi { $_[OBJ]->{_phi}; }
sub getv11 { $_[OBJ]->{_v11}; }
sub getv12 { $_[OBJ]->{_v12}; }
sub getv13 { $_[OBJ]->{_v13}; }
sub getv21 { $_[OBJ]->{_v21}; }
sub getv22 { $_[OBJ]->{_v22}; }
sub getv23 { $_[OBJ]->{_v23}; }
sub getv32 { $_[OBJ]->{_v32}; }
sub getv33 { $_[OBJ]->{_v33}; }
sub getv43 { $_[OBJ]->{_v43}; }
sub setrho { $_[OBJ]->{_rho} = $_[VALUE]; }
sub settheta { $_[OBJ]->{_theta} = $_[VALUE]; }
sub setphi { $_[OBJ]->{_phi} = $_[VALUE]; }
sub setv11 { $_[OBJ]->{_v11} = $_[VALUE]; }
sub setv12 { $_[OBJ]->{_v12} = $_[VALUE]; }
sub setv13 { $_[OBJ]->{_v13} = $_[VALUE]; }
sub setv21 { $_[OBJ]->{_v21} = $_[VALUE]; }
sub setv22 { $_[OBJ]->{_v22} = $_[VALUE]; }
sub setv23 { $_[OBJ]->{_v23} = $_[VALUE]; }
sub setv32 { $_[OBJ]->{_v32} = $_[VALUE]; }
sub setv33 { $_[OBJ]->{_v33} = $_[VALUE]; }
sub setv43 { $_[OBJ]->{_v43} = $_[VALUE]; }
use constant PW => 1;
use constant PE => 2;
sub eyecoord {
$_[PE]->setx( $_[OBJ]->getv11() * $_[PW]->getx()
+ $_[OBJ]->getv21() * $_[PW]->gety() );
$_[PE]->sety( $_[OBJ]->getv12() * $_[PW]->getx()
+ $_[OBJ]->getv22() * $_[PW]->gety()
+ $_[OBJ]->getv32() * $_[PW]->getz());
$_[PE]->setz( $_[OBJ]->getv13() * $_[PW]->getx()
+ $_[OBJ]->getv23() * $_[PW]->gety()
+ $_[OBJ]->getv33() * $_[PW]->getz()
+ $_[OBJ]->getv43() );
}
use constant REFPX => 2;
use constant REFPY => 3;
sub perspective {
my $pe = new Vector3D( 0.0, 0.0, 0.0, "PE" );
$_[OBJ]->eyecoord ( $_[PW], $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;
use constant ZMIN => 0;
use constant TAG =>1;
sub new {
my $pkg = shift;
bless {
_zmin => $_[ZMIN],
_tag => $_[TAG] || 'CLIPVOL'
}, $pkg;
}
use constant OBJ => 0;
use constant VALUE => 1;
sub setzmin { $_[OBJ]->{_zmin} = $_[VALUE]; }
sub settag { $_[OBJ]->{_tag} = $_[VALUE]; }
sub getzmin { $_[OBJ]->{_zmin}; }
sub gettag { $_[OBJ]->{_tag}; }
use constant PKG => 0;
use constant X0 => 1;
use constant Y0 => 2;
use constant Z0 => 3;
use constant X1 => 4;
use constant Y1 => 5;
use constant Z1 => 6;
sub Clip {
# refs to scalars
my ($pkg, $x0, $y0, $z0, $x1, $y1, $z1)
= ($_[PKG], $_[X0], $_[Y0], $_[Z0], $_[X1], $_[Y1], $_[Z1]);
#scalar
my $zmin = $pkg->getzmin();
my ($tmin, $tmax) = (0, 1);
my $dx = $$x1 - $$x0;
my $dz = $$z1 - $$z0;
my $dy = $$y1 - $$y0;
return 0 unless clipT( $dx+$dz, -$$x0-$$z0, $tmin, $tmax )
+ # Right side
and clipT( -$dx+$dz, $$x0-$$z0, $tmin, $tmax )
+ # Left side
and clipT( -$dy+$dz, $$y0-$$z0, $tmin, $tmax )
+ # Bottom side
and clipT( $dy+$dz, -$$y0-$$z0, $tmin, $tmax )
+ # Top side
# part of line is in -z <= x <= z, -z <= y <= z
and clipT( $dz, -$$z0 + $zmin, $tmin, $tmax )
+ # Front
and clipT( -$dz, -$$z0-1, $tmin, $tmax );
+ # Back
# part of line is visible in -z <= x <= z, -z <= y <= z, -1 <= x <
+= $zmin
# If end pt 1 (t=1) is not in region, compute intersection
$$x1 = $$x0 + $tmax * $dx
, $$y1 = $$y0 + $tmax * $dy
, $$z1 = $$z0 + $tmax * $dz
if $tmax < 1;
# If end pt 0 (t=0) is not in region, compute intersection
$$x0 = $$x0 + $tmin * $dx
, $$y0 = $$y0 + $tmin * $dy
, $$z0 = $$z0 + $tmin * $dz
if ( $tmin > 0 );
return 1;
}
###################################################################
###
### 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.
###
###################################################################
use constant DENOM => 0;
use constant NUM => 1;
use constant TE => 2; # OUT parameter (Aliased scalar )
use constant TL => 3; # OUT parameter (Aliased scalar )
sub clipT {
return ($_[NUM] > 0) ? 0 : 1 if $_[DENOM] == 0;
my $t = $_[NUM]/$_[DENOM];
if ( $_[DENOM] > 0 ) {
return 0 if $t > $_[TL];
$_[TE] = $t if $t > $_[TE];
}
elsif ( $_[DENOM] < 0 ) {
return 0 if $t < $_[TE];
$_[TL] = $t if $t < $_[TL];
}
return 1;
}
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 ha
+sh
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";
}
}
}
# Next 2 subs updated: Cleaner, more accurate refactorization
sub buildET4Zbuff {
my $pkg = shift;
# each entry in the Edge Table (ET) contains the Ymax coordinate o
+f 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, $Ymax) = ( $e->{edge}[0]->gety(), $e->{edge}[1]->gety(
+) );
my ($flag) = ($y < $Ymax);
($y, $Ymax) = ($Ymax, $y) unless $flag;
push @{$pkg->{ET}[$y]}, {
Ymax => $Ymax,
Xbot => ($flag) ? $e->{edge }[0]->getx() : $e-
+>{edge }[1]->getx(),
z => ($flag) ? $e->{edge3D}[0]->getz() : $e-
+>{edge3D}[1]->getz(),
invSlope => calcOneOverSlope($e),
};
}
my $highestY = $pkg->{highestY};
$pkg->{ET}[$_] and return $_ for 0..$highestY-1
}
sub fillZbuff {
my ($pkg, $zbuffer) = @_;
my $rgb = sprintf "#%03x", $pkg->{color};
my $y = $pkg->buildET4Zbuff();
my $ET = $pkg->{ET};
my @AET; #! Active Edge Table
do {
# Move from ET bucket y to the AET those edges whose Ymin = y
if ($ET->[$y]) {
@AET = sort{ $a->{Xbot} <=> $b->{Xbot} } @AET, @{$ET->[$y]
+};
$ET->[$y] = undef;
}
for ( my $i=0; $i<@AET; $i += 2 ) {
my ($left, $right) = $AET[$i+1] ? ($i, $i+1) : ($i-1, $
+i);
my $X1 = nearest_ceil (1, $AET[$left ]->{X
+bot} );
my $X2 = nearest_floor(1, $AET[$right]->{Xb
+ot} );
my $z = $AET[$left ]->{z};
my $dz = $AET[$right]->{z} - $z;
my $dx = $X2 - $X1;
$z += ($AET[$right] - $z) / $dx if $dx;
$z <= $zbuffer->[$_][$y] and $zbuffer->[$_][$y] = $z for
+($X1 .. $X2);
$pkg->{can}->create ( 'line', $X1, $y, $X2, $y, -fill => $
+rgb );
}
@AET = grep{
$_->{Ymax} != $y
#!! BEWARE !! ALL the bracketing in the next line is neces
+sary.
? ( ($_->{invSlope} and $_->{Xbot} += $_->{invSlope}), 1)
: 0
} @AET;
$y++;
} while( @AET and @$ET );
}
sub calcOneOverSlope {
my $e = shift;
my $y = $e->{edge}->[0]->gety() - $e->{edge}->[1]->gety();
return undef if $y == 0;
my $x = $e->{edge}->[0]->getx() - $e->{edge}->[1]->getx();
return $x/$y;
}
use constant EDGES => 0;
sub getHighestY {
my $highest = 0;
$highest < $_ and $highest = $_
for map{ $_->gety() }
map{ @{$_->{edge}} } @{$_[EDGES]};
return $highest;
}
use constant PACKAGE => 0;
use constant X => 1;
use constant Y => 2;
use constant COLOR => 3;
sub setPixel {
my $rgb = sprintf "#%03x", $_[COLOR];
$_[PACKAGE]->{can}->create ( 'line',
$_[X], $_[Y],
$_[X]+1, $_[Y]+1,
-fill => $rgb,
# -outline => $rgb
);
}
1;
}}
Examine what is said, not who speaks.