Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help??

Okay Tye, as requested. I started with the version of the code as currently posted at Z Buffer Demo which is a somewhat different version to the original I believe but is close enough for the differences made by rbc not to be an issue I think. I looked at trying to reverse all the non-trivial modifications I made to the original after I posted Micro optimisations can pay off, and needn't be a maintenance problem, but this proved beyond my memories capability after all this time.

The two sets of (crude) comparative timings below show that on my machine, the original code takes 2 minutes and 5 seconds. This was measured by installing print scalar localtime; at the top and bottom of the sub main::Doit Crude, but more accurate than the "watch the clock" method I was using when I did this first time around.

My optimised version of the code below shows that without making any changes to structure of either the code or the data, this timing has been reduced to under 4 seconds. I tried to stop when I acheived the original "around 20 seconds", but couldn't work out how.

Now the debate will centre on whether the changes I have made constitute micro-optimisations or not. Another reason for avoiding the debate in the first place. The changes I have made include.

  • Constantising parameter access.
  • Removal of temporary variable usage.
  • Common sub-expression elimination.
  • Re-coding of if, for(;;), while statements into their modifier forms
  • Merging of consecutive loops and/or nested loops into single loops or grep or map forms.
  • Moving invarient expressions, sub-expressions and statements from inside loops to outside.
  • In two cases only, manually in-lining two trivial functions where they are called in only one place and (IMO) served no purpose by way of clarification of the code and were therefore, pure overhead.

    The two functions are compDZ() and setPixel

I would characterise all these changes under the heading "re-factoring" as no functionality has been added, changed, or removed, nor been moved. I believe all these types of changes, have at various times by various people, been described as "micro-optimisations", and in that way been frowned upon. I did not set out to disprove this advice. I set out to assist a fellow monk with his question, and discovered that the edit/run cycle took so long that it discouraged me (and others if you look at the original thread). So, as I had an interest in seeing how the Z-buffer algorithm had been implemented, I set about trying to reduce the cycle time using simple changes. During this process, I found many places in the code where a single line would call several accessor subs. Each of these subs was shifting the argument list into named vars. Often these named vars were then passed as parameters to nested calls where they again were being shifted into another set of named vars. I originally recoded these accesses using the $_[n] nomenclature but that rapidly became confusing especially in subs where there were 4, 5 or 6 parameters.

I then hit upon the idea of using constant subs to give meaningful names to the parameters. I had recently read somewhere that constant subs are inlined by the compiler and therefore have no more overhead than coding the constant itself and when I benchmarked a small testcase, this proved to be the case. I felt that as I hadn't seen this "discovery" described anywhere else, it was worth sharing with the community and I made my post.

The controversy, such as it is, centers on the (obviously mathematically impossible) idea that a 25% reduction in attribute access could in some way be responsible for a "speed up factor of 6". (That phrase is in quotes because I never made that claim.) The obvious answer is "It cannot". And the reason I left the original question unanswered is that the answer is so obvious that I assumed it to be rhetorical.

In hindsight, the phrase "Reducing the draw time of the cube, from around 2 minutes (on my box) to around 20 secs." from my original post should have read "Contributing to a reduction in the draw time of the cube, from around 2 minutes (on my box) to around 20 secs.".

Had that read "from exactly 125.2 seconds to exactly 20.7", then I could have seen the source of the misunderstanding and the need for this belated re-examination. As it stands, if anyone feels that they where fooled by an obvious mathematical impossibility or that the idea of 'Constantising parameter access' was unworthy of a wider audience then I apologise.

Likewise, if anyone believes that understanding the costs and benefits of TIMTOWTDI, and using them to achieve a reduction in runtime of one, non-trivial, real-world application from 125 seconds to under 4 is not worthy of consideration, I again apologise.

Finally, if any monk feels that I profited unduly (in the oft-described, 'meaningless', XP stakes) from my original post (150 currently), then I invite them to downvote this post in recompense. Or if sufficient numbers believe that to be the case, I am quite sure that it is possible to have that number or any abitrary "fine" of XP deducted from my tally. I will not argue the point regardless.

Please find attached my crude timings of the original and modified programs along with the modified code. I did set out to diff the two and highlight each of the changes and give my justification for why each change was, in and of itself, a micro-optimisation, but I got bored with the whole laborious process and gave up. Sorry.

It might be worth noting that I did go on to make several more, decidedly non-trivial modifications when I was doing this originally. This included such things as

  • Using arrays and constants instead of hashes and named elements as the basis of the low-level classes.
  • Re-writing all the methods of those classes to use direct access to the instance data internally instead of the accessor functions.
  • Re-structuring the Z-Buffer itself to be a single linear array instead of an array of arrays.

Each of these steps had a further benefit on performance, but the main blockage had moved to the Tk code and that was beyond my (self-assigned) breif to modify. I think that doing the drawing into a bitmap and blitting this to the canvas would allow the performance to be reduced by (possibly) an order of magnitude, as the overhead inherent in drawing using discrete, hit-testable lines does nothing for the application as it stands.

Original code - timing and profile

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_floo
+r
 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

[download]

Optimised code - timing and profile

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::_AutoloadTkWi
+dget
 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

[download]

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,
    "!="    => \&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 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;
}}

[download]

Examine what is said, not who speaks.

In reply to Re: Re^2: Micro optimisations can pay off, and needn't be a maintenance problem (I don't believe it) by BrowserUk
in thread Micro optimisations can pay off, and needn't be a maintenance problem by BrowserUk

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others studying the Monastery: (6)
As of 2024-04-18 06:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found