C:\test\rbc\tye>3d
Fri Dec 27 23:39:22 2002
Fri Dec 27 23:41:27 2002

C:\test\rbc\tye>dprofpp -F
Faking 8 exit timestamp(s).
Total Elapsed Time = -23.5459 Seconds
  User+System Time =        0 Seconds
Exclusive Times
%Time ExclSec CumulS #Calls sec/call Csec/c  Name
 0.00   53.98 206.29  88577   0.0006 0.0023  Tk::WidgetMethod
 0.00   47.45 43.704 255064   0.0002 0.0002  Tk::winfo
 0.00   20.56 153.56      1   20.559 153.56  main::doit
 0.00   19.87 55.982 255095   0.0001 0.0002  Tk::Submethods::__ANON__
 0.00   13.24 67.606  88576   0.0001 0.0008  PolygonZbuffer::setPixel
 0.00   8.775 76.860      5   1.7550 15.371  PolygonZbuffer::fillZbuff
 0.00   6.884 210.54  88577   0.0001 0.0024  Tk::__ANON__
 0.00   0.459  1.695      7   0.0656 0.2421  main::BEGIN
 0.00   0.240  0.629     14   0.0172 0.0449  base::import
 0.00   0.229  0.239    908   0.0003 0.0003  Math::Round::nearest_ceil
 0.00   0.220  0.259      3   0.0733 0.0865  Math::Trig::BEGIN
 0.00   0.189  0.169    908   0.0002 0.0002  Math::Round::nearest_floor
 0.00   0.161  0.200     34   0.0047 0.0059  Exporter::import
 0.00   0.120  0.138     11   0.0109 0.0125  PolygonZbuffer::BEGIN
 0.00   0.099 153.78    224   0.0004 0.6865  Tk::DoOneEvent

##</code><code>##

C:\test\rbc\tye>perl -d:DProf 3d.pl
Sun Dec 29 04:15:35 2002
Sun Dec 29 04:15:39 2002

C:\test\rbc\tye>dprofpp -O 30 -R -F
Garbled profile, faking exit timestamp:
        Vector2D::BEGIN => .
Total Elapsed Time = -0.40205 Seconds
  User+System Time = 6.797075 Seconds
Exclusive Times
%Time ExclSec CumulS #Calls sec/call Csec/c  Name
 20.9   1.423  3.923      1   1.4234 3.9228  main::doit
 18.8   1.283  1.933      5   0.2565 0.3866  PolygonZbuffer::fillZbuff
 8.09   0.550  4.460    916   0.0006 0.0049  Tk::WidgetMethod
 7.93   0.539  1.764     13   0.0415 0.1357  main::BEGIN
 5.41   0.368  4.409    277   0.0013 0.0159  Tk::DoOneEvent
 2.94   0.200  0.249      3   0.0666 0.0832  Math::Trig::BEGIN
 2.80   0.190  0.618     14   0.0136 0.0442  base::import
 2.66   0.181  0.220     35   0.0052 0.0063  Exporter::import
 1.91   0.130  0.122    545   0.0002 0.0002  Tk::winfo
 1.77   0.120  0.128     19   0.0063 0.0067  PolygonZbuffer::BEGIN
 1.77   0.120  4.553    916   0.0001 0.0050  Tk::__ANON__
 1.32   0.090  0.289      7   0.0128 0.0412  Tk::MainWindow::BEGIN
 1.32   0.090  0.129      2   0.0449 0.0643  Tk::Widget::_AutoloadTkWidget
 1.19   0.081  0.176      1   0.0809 0.1759  Tk::Widget::packAdjust
 1.18   0.080  0.088      1   0.0799 0.0885  Tk::update
 1.18   0.080  0.052   1870   0.0000 0.0000  POSIX::floor
 1.03   0.070  0.065    325   0.0002 0.0002  Vector3D::new
 1.02   0.069  0.207    130   0.0005 0.0016  Perspective::perspective
 0.88   0.060  0.100      1   0.0600 0.0998  vars::BEGIN
 0.88   0.060  0.060      2   0.0300 0.0299  DynaLoader::BEGIN
 0.88   0.060  0.164    576   0.0001 0.0003  Tk::Submethods::__ANON__
 0.85   0.058  0.090    130   0.0004 0.0007  Perspective::eyecoord
 0.77   0.052  4.456      1   0.0516 4.4563  Tk::MainLoop
 0.74   0.050  0.050      3   0.0166 0.0166  Math::Complex::BEGIN
 0.74   0.050  0.040    686   0.0001 0.0001  Vector3D::getz
 0.74   0.050  0.090      7   0.0071 0.0128  AutoLoader::import
 0.74   0.050  0.389     11   0.0045 0.0354  Tk::BEGIN
 0.74   0.050  0.054     86   0.0006 0.0006  Tk::Derived::Delegate
 0.59   0.040  0.040      5   0.0080 0.0080  Exporter::export
 0.46   0.031  0.260      3   0.0103 0.0867  Tk::Event::BEGIN

##</code><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' ) for 1 .. $#{$_[SHAPE]};
}

use constant POINTS => 0;
sub DrawPolygon {
    my @edges;

    push @edges, ProjectLine( $_[POINTS]->[$_-1], $_[POINTS]->[$_] ) for 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_center))
            ),
            new Vector2D (
                nearest_ceil( 1, $screenDist * $x2 + $x_center ),
                nearest_floor( 1, $YMAX - ($screenDist * $y2 + $y_center))
            ),
        )
    }
}

###
### Set up the GUI
###
$can->packAdjust( -side => 'left', -fill => 'both', -delay => 1 );
$frame->pack( -side   => 'left', -fill   => 'y', -expand => 'y', -anchor => 'w' );

my $rotZbutton = $frame->Button( -relief => "groove", -text => "rotZ = ", )->pack( anchor => 'w' );
my $rotZentry  = $frame->Entry ( -width  => 10, -textvariable => \$rotateZ)->form( -left => [$rotZbutton,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 $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   => \$zmin)
            ->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,
    "!="    => \&notEqual;

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 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";
        }
    }
}

# Next 2 subs updated: Cleaner, more accurate refactorization

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, $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 ]->{Xbot} );
			my $X2				= nearest_floor(1, $AET[$right]->{Xbot} );
			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 necessary.
			? ( ($_->{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;
}}