The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

Draw

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

Synopsis

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);

Description

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;
 
 

Constructors

draw

Constructor

 sub draw() {bless {}}
 
 

Methods

from

Set view point

 sub from($$)
  {my ($d) =         check(@_[0..0]); # Drawing 
   my ($v) = vectorCheck(@_[1..1]); # Vector
 
   $d->{from} = $v;
   $d;
  }
 
 

to

Viewing this point

 sub to($$)
  {my ($d) =         check(@_[0..0]); # Drawing 
   my ($v) = vectorCheck(@_[1..1]); # Vector
 
   $d->{to} = $v;
   $d;
  }
 
 

Horizon

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

Light source position

 sub light($$)
  {my ($d) =         check(@_[0..0]); # Drawing 
   my ($v) = vectorCheck(@_[1..1]); # Vector
 
   $d->{light} = $v;
   $d;
  }
 
 

withControls

Display a window allowing the user to set to,from,horizon,light

 sub withControls($)
  {my ($d) =         check(@_[0..0]); # Drawing 
 
   $d->{withControls} = 1;
   $d;
  }
 

object

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

done

Draw the complete object list

 sub done($)
  {my ($d) = check(@_[0..0]); # Drawing 
   &fission($d);
   &new($d);
  }
 
 

Methods

print

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

Check its a drawing

 sub check(@)
  {if (debug)
    {for my $t(@_)
      {confess "$t is not a drawing" unless ref($t) eq __PACKAGE__;
      }
    } 
   return (@_)
  }
 
 

is

Test its a drawing

 sub is(@)
  {for my $t(@_)
    {return 0 unless ref($t) eq __PACKAGE__;
    }
   'draw';
  }
 
 

showFissionFragments

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

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

New drawing - not a constructor

 sub new($)
  {my ($d) = check(@_[0..0]); # Drawing 
   &newCanvas ($d);
   &newControl($d);
   &drawing   ($d, 1);
   MainLoop;
  } 
 
 

newCanvas

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')]);
 }
 

newControl

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

Configure

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

drawing

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

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

zorder

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

Exports

Export "draw"

 use Math::Zap::Exports qw(
   draw ()
  );
 
 #_ Draw ________________________________________________________________
 # Package loaded successfully
 #_______________________________________________________________________
 
 1;
 
 
 

Credits

Author

philiprbrenan@yahoo.com

philiprbrenan@yahoo.com, 2004

License

Perl License.