Draw 3d scene as 2d image with lighting and shadowing to assist the human observer in reconstructing the original 3d scene.
PhilipRBrenan@yahoo.com, 2004, Perl License
Example t/draw.t
#!perl -w #______________________________________________________________________ # Test drawing. # philiprbrenan@yahoo.com, 2004, Perl License #______________________________________________________________________ use Math::Zap::Draw; use Math::Zap::Cube unit=>'cu'; use Math::Zap::Triangle; use Math::Zap::Vector; use Test::Simple tests=>1; #_ Draw _______________________________________________________________ # Draw this set of objects. #______________________________________________________________________ $l = draw ->from (vector( 10, 10, 10)) ->to (vector( 0, 0, 0)) ->horizon (vector( 1, 0.5, 0)) ->light (vector( 20, 30, -20)) ->object(triangle(vector( 0, 0, 0), vector( 8, 0, 0), vector( 0, 8, 0)), 'red') ->object(triangle(vector( 0, 0, 0), vector( 0, 0, 8), vector( 0, 8, 0)), 'green') ->object(triangle(vector( 0, 0, 0), vector(12, 0, 0), vector( 0, 0, 12)) - vector(2.5, 0, 2.5), 'blue') ->object(triangle(vector( 0, 0, 0), vector( 8, 0, 0), vector( 0, -8, 0)), 'pink') ->object(triangle(vector( 0, 0, 0), vector( 0, 0, 8), vector( 0, -8, 0)), 'orange') ->object(cu()*2+vector(3,5,1), 'lightblue') ->print; $L = <<'END'; #!perl -w use Math::Zap::Draw; use Math::Zap::Triangle; use Math::Zap::Vector; draw ->from (vector(10, 10, 10)) ->to (vector(0, 0, 0)) ->horizon (vector(1, 0.5, 0)) ->light (vector(20, 30, -20)) ->object(triangle(vector(0, 0, 0), vector(8, 0, 0), vector(0, 8, 0)), 'red') ->object(triangle(vector(0, 0, 0), vector(0, 0, 8), vector(0, 8, 0)), 'green') ->object(triangle(vector(-2.5, 0, -2.5), vector(9.5, 0, -2.5), vector(-2.5, 0, 9.5)), 'blue') ->object(triangle(vector(0, 0, 0), vector(8, 0, 0), vector(0, -8, 0)), 'pink') ->object(triangle(vector(0, 0, 0), vector(0, 0, 8), vector(0, -8, 0)), 'orange') ->object(triangle(vector(3, 5, 1), vector(5, 5, 1), vector(3, 7, 1)), 'lightblue') ->object(triangle(vector(5, 7, 1), vector(5, 5, 1), vector(3, 7, 1)), 'lightblue') ->object(triangle(vector(3, 5, 3), vector(5, 5, 3), vector(3, 7, 3)), 'lightblue') ->object(triangle(vector(5, 7, 3), vector(5, 5, 3), vector(3, 7, 3)), 'lightblue') ->object(triangle(vector(3, 5, 1), vector(3, 7, 1), vector(3, 5, 3)), 'lightblue') ->object(triangle(vector(3, 7, 3), vector(3, 7, 1), vector(3, 5, 3)), 'lightblue') ->object(triangle(vector(5, 5, 1), vector(5, 7, 1), vector(5, 5, 3)), 'lightblue') ->object(triangle(vector(5, 7, 3), vector(5, 7, 1), vector(5, 5, 3)), 'lightblue') ->object(triangle(vector(3, 5, 1), vector(3, 5, 3), vector(5, 5, 1)), 'lightblue') ->object(triangle(vector(5, 5, 3), vector(3, 5, 3), vector(5, 5, 1)), 'lightblue') ->object(triangle(vector(3, 7, 1), vector(3, 7, 3), vector(5, 7, 1)), 'lightblue') ->object(triangle(vector(5, 7, 3), vector(3, 7, 3), vector(5, 7, 1)), 'lightblue') ->done; END ok($l eq $L);
This package supplies methods to draw a scene, containing three dimensional objects, as a two dimensional image, using lighting and shadowing to assist the human observer in reconstructing the original three dimensional scene.
There are many existing packages to perform this important task: this package Math::Zap::Is the only one to make the attempt in Pure Perl. Pending the $VERSION=1.07; power of Petaflop Parallel Perl (when we will be set free from C), this approach is slow. However, it is not so slow as to be completely useless for simple scenes as might be encountered inside, say for instance, beam lines used in high energy particle physics, the owners of which often have large Perl computers.
The key advantage of this package is that is open: you can manipulate both the objects to be drawn and the drawing itself all in Pure Perl.
package Math::Zap::Draw; $VERSION=1.07; use Math::Zap::Vector check=>'vectorCheck'; use Math::Zap::Vector2; use Math::Zap::Triangle2 newnnc=>'triangle2Newnnc'; use Math::Zap::Triangle; use Math::Zap::Color; use Tk; use Carp; use constant debug=>0;
Constructor
sub draw() {bless {}}
Set view point
sub from($$) {my ($d) = check(@_[0..0]); # Drawing my ($v) = vectorCheck(@_[1..1]); # Vector $d->{from} = $v; $d; }
Viewing this point
sub to($$) {my ($d) = check(@_[0..0]); # Drawing my ($v) = vectorCheck(@_[1..1]); # Vector $d->{to} = $v; $d; }
Sets the direction of the horizon.
sub horizon($$) {my ($d) = check(@_[0..0]); # Drawing my ($v) = vectorCheck(@_[1..1]); # Vector $d->{horizon} = $v; $d; }
Light source position
sub light($$) {my ($d) = check(@_[0..0]); # Drawing my ($v) = vectorCheck(@_[1..1]); # Vector $d->{light} = $v; $d; }
Display a window allowing the user to set to,from,horizon,light
sub withControls($) {my ($d) = check(@_[0..0]); # Drawing $d->{withControls} = 1; $d; }
Draw this object
sub object($$$) {my ($d) = check(@_[0..0]); # Drawing my ($o) = @_[1..1]; # Object to be drawn my ($c) = @_[2..2]; # Color of object's surfaces if ($o->can('triangulate')) {push @{$d->{triangles}}, $o->triangulate($c); } else {die "Cannot draw $o"; } $d; }
Draw the complete object list
sub done($) {my ($d) = check(@_[0..0]); # Drawing &fission($d); &new($d); }
Print the complete object list as a triangles in a reusable manner.
sub print($) {my ($d) = check(@_[0..0]); # Drawing my $l = << 'END'; #!perl -w use Math::Zap::Draw; use Math::Zap::Triangle; use Math::Zap::Vector; draw END $l .= '->from ('. $d->{from} ->print .")\n"; $l .= '->to ('. $d->{to} ->print .")\n"; $l .= '->horizon ('. $d->{horizon}->print .")\n"; $l .= '->light ('. $d->{light} ->print .")\n"; for my $p(@{$d->{triangles}}) # Triangulation {$l .= ' ->object('. $p->{triangle}->print .', \''. $p->{color}. "\')\n"; } $l .= "->done;\n"; }
Check its a drawing
sub check(@) {if (debug) {for my $t(@_) {confess "$t is not a drawing" unless ref($t) eq __PACKAGE__; } } return (@_) }
Test its a drawing
sub is(@) {for my $t(@_) {return 0 unless ref($t) eq __PACKAGE__; } 'draw'; }
Show fission fragments: the objects to be drawn are triangulated where-ever they may intersect. It is useful to see these sub triangles when debugging. See also "fission".
sub showFissionFragments($) {my ($d) = check(@_[0..0]); # Drawing $d->{showFissionFragments} = 1; $d; }
Fission the triangles that intersect. See "showFissionFragments"
sub fission($) {my ($d) = check(@_[0..0]); # Drawing my @P = @{$d->{triangles}}; # Triangles to be fissoned my $tested; # Source triangles already tested #_ Draw ________________________________________________________________ # Check each pair of triangles #_______________________________________________________________________ L: for(;;) {for (my $i = 0; $i < scalar(@P); ++$i) {my $p = $P[$i]; next unless defined($p); #_ Draw ________________________________________________________________ # Check against triangle #_______________________________________________________________________ for (my $j = $i+1; $j < scalar(@P); ++$j) {my $q = $P[$j]; next unless defined($q); my ($t, @t, @T); #_ Draw ________________________________________________________________ # Already tested #_______________________________________________________________________ next if $tested->{$p->{plane}}{$q->{plane}}; $tested->{$p->{plane}}{$q->{plane}} = 1; $tested->{$q->{plane}}{$p->{plane}} = 1; next if $p->{triangle}->parallel($q->{triangle}); #_ Draw ________________________________________________________________ # Divide intersecting triangles #_______________________________________________________________________ @t = $p->{triangle}->divide($q->{triangle}); @T = $q->{triangle}->divide($p->{triangle}); #_ Draw ________________________________________________________________ # Add divisions to list of triangles #_______________________________________________________________________ next unless @t > 1 or @T > 1; delete $P[$i]; delete $P[$j]; push @P, {triangle=>$_, color=>$q->{color}, plane=>$q->{plane}} for(@t); push @P, {triangle=>$_, color=>$p->{color}, plane=>$p->{plane}} for(@T); next L; } } last; } #_ Draw ________________________________________________________________ # Update list of triangles to be drawn #_______________________________________________________________________ my @p; for my $p(@P) {push @p, $p if defined($p); } $d->{triangles} = [@p]; }
New drawing - not a constructor
sub new($) {my ($d) = check(@_[0..0]); # Drawing &newCanvas ($d); &newControl($d); &drawing ($d, 1); MainLoop; }
Canvas for drawing
sub newCanvas($) {my ($d) = check(@_[0..0]); # Drawing my $m = $d->{MainWindowCanvas} = new MainWindow; my $c = $d->{canvas} = $m->Canvas(-background=>'yellow')->pack(-expand=>1, -fill=>'both'); $d->{canvas}{width} = $c->cget(-width=>); $d->{canvas}{height} = $c->cget(-height=>); $c->CanvasBind('<Configure>' => [$d=>'configure', Ev('w'), Ev('h')]); }
Controls for drawing
sub newControl() {my ($d) = check(@_[0..0]); # Drawing my $m = $d->{MainWindowControls} = new MainWindow; my $a11 = $d->{a11} = $m->Label(-text=>'View point'); my $a12 = $d->{a12} = $m->Entry(-textvariable=>\$d->{from}->{x}); my $a13 = $d->{a13} = $m->Entry(-textvariable=>\$d->{from}->{y}); my $a14 = $d->{a14} = $m->Entry(-textvariable=>\$d->{from}->{z}); my $a21 = $d->{a21} = $m->Label(-text=>'Looking to'); my $a22 = $d->{a22} = $m->Entry(-textvariable=>\$d->{to}->{x}); my $a23 = $d->{a23} = $m->Entry(-textvariable=>\$d->{to}->{y}); my $a24 = $d->{a24} = $m->Entry(-textvariable=>\$d->{to}->{z}); my $a31 = $d->{a31} = $m->Label(-text=>'Horizontal'); my $a32 = $d->{a32} = $m->Entry(-textvariable=>\$d->{horizon}->{x}); my $a33 = $d->{a33} = $m->Entry(-textvariable=>\$d->{horizon}->{y}); my $a34 = $d->{a34} = $m->Entry(-textvariable=>\$d->{horizon}->{z}); my $a41 = $d->{a41} = $m->Label(-text=>'Lit from'); my $a42 = $d->{a42} = $m->Entry(-textvariable=>\$d->{light}->{x}); my $a43 = $d->{a43} = $m->Entry(-textvariable=>\$d->{light}->{y}); my $a44 = $d->{a44} = $m->Entry(-textvariable=>\$d->{light}->{z}); my $a51 = $d->{a51} = $m->Button(-text=>'Redraw', -command=>sub{&drawing($d, 1)}); my $a52 = $d->{a52} = $m->Button(-text=>'In'); my $a53 = $d->{a53} = $m->Button(-text=>'Out'); my $a54 = $d->{a54} = $m->Button(-text=>'Quit', -command=>sub{exit(0)}); $a11->grid($a12, $a13, $a14); $a21->grid($a22, $a23, $a24); $a31->grid($a32, $a33, $a34); $a41->grid($a42, $a43, $a44); $a51->grid($a52, $a53, $a54); }
Configuration of canvas has been changed
sub configure {my ($d) = check(@_[0..0]); # Drawing my $c = $d->{canvas}; $d->{canvas}{width} = $_[1]; $d->{canvas}{height} = $_[2]; &drawing($d, 0); }
New drawing of objects
sub drawing($$) {my ($d) = check(@_[0..0]); # Drawing my $zorder = shift; # Re-sort of zorder required? #_ Draw ________________________________________________________________ # Locate background #_______________________________________________________________________ my $from = $d->{from}; # View point my $lt = $d->{light}; # Light my $to = $d->{to}; # View towards my $hz = $d->{horizon}; # Horizon my $v = (($from-$to) x $hz)->norm; # Vertical in background plane my $h = ($v x ($from-$to))->norm; # Horizontal in background plane my $B = triangle($to, $to+$h, $to+$v); # Background plane $d->{background} = $B; &zorder($d) if $zorder; # Partially order triangles from view point $d->{canvas}->delete('all'); # Clear canvas #_ Draw ________________________________________________________________ # Dimensions of projected image #_______________________________________________________________________ my ($mx, $Mx, $my, $My); for my $D(@{$d->{triangles}}) {my $t = $B->project($D->{triangle}, $from); # Project onto background $D->{project} = $t; # Optimization - record for reuse my ($ax, $ay) = ($t->a->x, $t->a->y); my ($bx, $by) = ($t->b->x, $t->b->y); my ($cx, $cy) = ($t->c->x, $t->c->y); $mx = $ax if !defined($mx) or $mx > $ax; $mx = $bx if !defined($mx) or $mx > $bx; $mx = $cx if !defined($mx) or $mx > $cx; $Mx = $ax if !defined($Mx) or $Mx < $ax; $Mx = $bx if !defined($Mx) or $Mx < $bx; $Mx = $cx if !defined($Mx) or $Mx < $cx; $my = $ay if !defined($my) or $my > $ay; $my = $by if !defined($my) or $my > $by; $my = $cy if !defined($my) or $my > $cy; $My = $ay if !defined($My) or $My < $ay; $My = $by if !defined($My) or $My < $by; $My = $cy if !defined($My) or $My < $cy; } my $cw = $d->{canvas}{width}; my $ch = $d->{canvas}{height}; my $sx = int($d->{canvas}{width} /($Mx-$mx)); my $sy = int($d->{canvas}{height}/($My-$my)); my $s = $d->{canvas}{scale} = ($sx < $sy ? $sx : $sy); my $dx = $d->{canvas}{dx} = -$mx * $s + ($cw - $s * ($Mx-$mx)) / 2; my $dy = $d->{canvas}{dy} = $My * $s + ($ch - $s * ($My-$my)) / 2; #_ Draw ________________________________________________________________ # Draw each triangle #_______________________________________________________________________ for my $D(@{$d->{triangles}}) {my $T = $D->{triangle}; my $color = $D->{color}; my $p = $D->{plane}; my $t = $D->{project}; # Coordinates of triangle to be drawn my @a = ($dx+$t->a->x*$s, $dy-$t->a->y*$s, $dx+$t->b->x*$s, $dy-$t->b->y*$s, $dx+$t->c->x*$s, $dy-$t->c->y*$s, ); push @a, -outline=>'black' if defined($d->{showFissionFragments}); #_ Draw ________________________________________________________________ # Side towards/away from the light #_______________________________________________________________________ my $fb = $T->frontInBehindZ($from, $lt); if (!defined($fb) or $fb < 0) # Towards light {push @a, -fill=>$color; $d->{canvas}->createPolygon(@a); &shadows($d, $D); } else # Away from light {$d->{canvas}->createPolygon(@a, -fill=>color($color)->dark); } } }
Shadows from a point of illumination
sub shadows($$) {my ($d) = check(@_[0..0]); # Drawing my ($p) = (@_[1..1]); # Current triangle to be drawn my $from = $d->{from}; # View point my $to = $d->{to}; # Look towards my $light = $d->{light}; # Position of light my $back = $d->{background}; # Background my $c = $d->{canvas}; # Canvas my $dx = $d->{canvas}{dx}; # Canvas center x my $dy = $d->{canvas}{dy}; # Canvas center y my $s = $d->{canvas}{scale}; # Scale factor #_ Draw ________________________________________________________________ # Shadow each triangle #_______________________________________________________________________ my @s; for my $q(@{$d->{triangles}}) {next if $p == $q; # Do not shadow self next if $p->{plane} == $q->{plane}; # Do not shadow stuff in same plane my $t = $p->{triangle}; # Shadowed triangle my $T = $q->{triangle}; # Shadowing triangle # next if $t->frontInBehindZ($from, $light) > 0; # Check that plane view point and light my $b = $t->project($T, $light); # Project Shadowing triangle onto shadowed triangle my $d = triangle2Newnnc # Shadow in shadowed plane coordinates (vector2($b->a->x, $b->a->y), vector2($b->b->x, $b->b->y), vector2($b->c->x, $b->c->y) ); my $D = triangle2Newnnc # Shadowed plane (vector2(0,0), vector2(1,0), vector2(0,1) ); return if $d->narrow(); # Projected shadow too narrow? return if $D->narrow(); # Shadowed triangle too narrow? my @r = $d->ring($D); # Ring of common points if (scalar(@r) > 2) # Less than two - small intersection {my @a; for my $r(@r) # Points of intersection current/shadowing triangle {my $sr = $t->convertPlaneToSpace($r); # Convert intersection to space coords last if $T->frontInBehind($light, $sr) == 1; # $t gives back of shadowing plane my $sb = $back->intersectionInPlane($from, $sr); # Project from view point onto background push @a, $dx+$sb->x*$s, $dy-$sb->y*$s; # Save coordinates } #_ Draw ________________________________________________________________ # Draw shadow #_______________________________________________________________________ push @a, -outline=>color($p->{color})->dark, -fill=>color($p->{color})->dark; $c->createPolygon(@a); } } }
Z-order: order the fission triangles from the back ground to the point of view:
Compare each triangle with every other, recording for each triangle which triangles are behind it.
Place all triangles with no triangles behind them with at the start of the order.
Reprocess the remainder until none left (success) or a cycle is detected (bad algorithm).
The two triangles to be compared are projected on to the background: if their projections have no points in common they are unordered, otherwise use the distance to each triangle from the view point towards the common point as a measure of which is first.
fission() guarantees that no two triangles intersect, this algorithm should correctly order each pair of triangles.
sub zorder($) {my ($d) = check(@_[0..0]); # Drawing my $from = $d->{from}; # View point my $back = $d->{background}; # Background my @P = @{$d->{triangles}}; # Triangles to be drawn #_ Draw ________________________________________________________________ # Filter for useful triangles #_______________________________________________________________________ my @o; for(my $ip = 0; $ip < @P; ++$ip) {my $t = $P[$ip]{triangle}; # next unless $t->area > .1; # Ignore small triangles # next if $t->narrow(0); $o{$ip} = {}; push @o, $ip; } #_ Draw ________________________________________________________________ # Relationship #_______________________________________________________________________ for my $ip(@o) {my $t = $P[$ip]{triangle}; for my $jp(@o) {next unless $ip < $jp; my $T = $P[$jp]{triangle}; my $i = $back->project($t, $from); my $I = $back->project($T, $from); my $i2 = triangle2Newnnc(vector2($i->a->x, $i->a->y), vector2($i->b->x, $i->b->y), vector2($i->c->x, $i->c->y)); my $I2 = triangle2Newnnc(vector2($I->a->x, $I->a->y), vector2($I->b->x, $I->b->y), vector2($I->c->x, $I->c->y)); # next if $i2->narrow(0); # next if $I2->narrow(0); my @c = $i2->pointsInCommon($I2); next unless scalar(@c); for my $c(@c) {my $C = $back->convertPlaneToSpace($c); my $d = $t->distanceToPlaneAlongLine($from, $C); my $D = $T->distanceToPlaneAlongLine($from, $C); next if abs($d-$D) < 0.1; # Points to close in space to disambiguate $o{$ip}{$jp} = 1 if $d < $D; # Assumes order does not matter for coplanar triangles $o{$jp}{$ip} = 1 if $d > $D; # Assumes order does not matter for coplanar triangles last; } } } #_ Draw ________________________________________________________________ # Order by relationship #_______________________________________________________________________ my @p; for(;;) {my $n = 0; for my $i(sort(keys(%o))) {unless (keys(%{$o{$i}})) {push @p, $P[$i]; delete $o{$i}; ++$n; for my $j(keys(%o)) {delete $o{$j}{$i}; } } } last unless $n; } keys(%o) == 0 or warn "Cycle present??"; $d->{triangles} = [@p]; }
Export "draw"
use Math::Zap::Exports qw( draw () ); #_ Draw ________________________________________________________________ # Package loaded successfully #_______________________________________________________________________ 1;
philiprbrenan@yahoo.com
philiprbrenan@yahoo.com, 2004
Perl License.
To install Math::Zap::Draw, copy and paste the appropriate command in to your terminal.
cpanm
cpanm Math::Zap::Draw
CPAN shell
perl -MCPAN -e shell install Math::Zap::Draw
For more information on module installation, please visit the detailed CPAN module installation guide.