"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Graphics/TriD/TriD/Objects.pm" between
PDL-2.077.tar.gz and PDL-2.078.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

Objects.pm  (PDL-2.077):Objects.pm  (PDL-2.078)
skipping to change at line 36 skipping to change at line 36
package PDL::Graphics::TriD::GObject; package PDL::Graphics::TriD::GObject;
use strict; use strict;
use warnings; use warnings;
use base qw/PDL::Graphics::TriD::Object/; use base qw/PDL::Graphics::TriD::Object/;
use fields qw/Points Colors Options/; use fields qw/Points Colors Options/;
$PDL::Graphics::TriD::verbose //= 0; $PDL::Graphics::TriD::verbose //= 0;
sub new { sub new {
my($type,$points,$colors,$options) = @_; my($type,$points,$colors,$options) = @_;
print "GObject new.. calling SUPER::new...\n" if($PDL::Graphics::TriD::ve rbose); print "GObject new.. calling SUPER::new...\n" if($PDL::Graphics::TriD::ve rbose);
my $this = $type->SUPER::new(); my $this = $type->SUPER::new();
print "GObject new - back (SUPER::new returned $this)\n" if($PDL::Graphic s::TriD::verbose); print "GObject new - back (SUPER::new returned $this)\n" if($PDL::Graphic s::TriD::verbose);
if(!defined $options and ref $colors eq "HASH") { if(!defined $options and ref $colors eq "HASH") {
$options = $colors; $options = $colors;
undef $colors; undef $colors;
} }
$options = { $options ? %$options : () };
$options->{UseDefcols} = 1 if !defined $colors; # for VRML efficiency
$this->{Options} = $options;
$this->check_options;
print "GObject new - calling realcoords\n" if($PDL::Graphics::TriD::verbo se); print "GObject new - calling realcoords\n" if($PDL::Graphics::TriD::verbo se);
$points = PDL::Graphics::TriD::realcoords($type->r_type,$points); $this->{Points} = $points = PDL::Graphics::TriD::realcoords($type->r_type ,$points);
print "GObject new - back from realcoords\n" if($PDL::Graphics::TriD::ve rbose); print "GObject new - back from realcoords\n" if($PDL::Graphics::TriD::ve rbose);
$this->{Colors} = defined $colors
if(!defined $colors) {$colors = PDL->pdl(1,1,1); ? PDL::Graphics::TriD::realcoords("COLOR",$colors)
$colors = $type->cdummies($colors,$points); : $this->cdummies(PDL->pdl(1,1,1),$points);
$options->{UseDefcols} = 1; # for VRML efficiency
} else {
$colors = PDL::Graphics::TriD::realcoords("COLOR",$colors);
}
$this->{Options} = $options;
$this->{Points} = $points;
$this->{Colors} = $colors;
$this->check_options();
print "GObject new - returning\n" if($PDL::Graphics::TriD::verbose); print "GObject new - returning\n" if($PDL::Graphics::TriD::verbose);
return $this; return $this;
} }
sub check_options { sub check_options {
my($this) = @_; my($this) = @_;
my %newopts;
my $opts = $this->get_valid_options(); my $opts = $this->get_valid_options();
$this->{Options} = $opts, return if !$this->{Options};
print "FETCHOPT: $this ".(join ',',%$opts)."\n" if $PDL::Graphics::TriD:: verbose; print "FETCHOPT: $this ".(join ',',%$opts)."\n" if $PDL::Graphics::TriD:: verbose;
for(keys %$opts) { my %newopts = (%$opts, %{$this->{Options}});
$newopts{$_} = !exists $this->{Options}{$_} ? $opts->{$_} : delet my @invalid = grep !exists $opts->{$_}, keys %newopts;
e $this->{Options}{$_}; die "Invalid options left: @invalid" if @invalid;
}
if(keys %{$this->{Options}}) {
die("Invalid options left: ".(join ',',%{$this->{Options}}));
}
$this->{Options} = \%newopts; $this->{Options} = \%newopts;
} }
sub set_colors { sub set_colors {
my($this,$colors) = @_; my($this,$colors) = @_;
if(ref($colors) eq "ARRAY"){ if(ref($colors) eq "ARRAY"){
$colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors);
} }
$this->{Colors}=$colors; $this->{Colors}=$colors;
$this->data_changed; $this->data_changed;
} }
sub get_valid_options { sub get_valid_options { +{UseDefcols => 0} }
return {UseDefcols => 0}; sub get_points { $_[0]{Points} }
} sub cdummies { $_[1] }
sub r_type { "" }
sub get_points { sub defcols { $_[0]{Options}{UseDefcols} }
return $_[0]->{Points};
}
# In the future, have this happen automatically by the ndarrays. # In the future, have this happen automatically by the ndarrays.
sub data_changed { sub data_changed {
my($this) = @_; my($this) = @_;
$this->changed(); $this->changed;
}
sub cdummies {return $_[1];}
sub r_type { return ""; }
sub defcols {
return defined($_[0]->{Options}->{UseDefcols}) &&
$_[0]->{Options}->{UseDefcols};
} }
1;
package PDL::Graphics::TriD::Points; package PDL::Graphics::TriD::Points;
use base qw/PDL::Graphics::TriD::GObject/; use base qw/PDL::Graphics::TriD::GObject/;
sub get_valid_options { sub get_valid_options {
return {UseDefcols => 0, PointSize=> 1}; return {UseDefcols => 0, PointSize=> 1};
} }
package PDL::Graphics::TriD::Spheres; package PDL::Graphics::TriD::Spheres;
use base qw/PDL::Graphics::TriD::GObject/; use base qw/PDL::Graphics::TriD::GObject/;
sub get_valid_options { # need to add radius # need to add radius
return {UseDefcols => 0, PointSize=> 1}; sub get_valid_options {
+{UseDefcols => 0, PointSize=> 1}
} }
package PDL::Graphics::TriD::Lines;
use base qw/PDL::Graphics::TriD::GObject/;
sub cdummies { return $_[1]->dummy(1); }
sub r_type { return "SURF2D";}
sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; }
package PDL::Graphics::TriD::LineStrip;
use base qw/PDL::Graphics::TriD::GObject/;
sub cdummies { return $_[1]->dummy(1); }
sub r_type { return "SURF2D";}
sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; }
########################################################################### ###########################################################################
################# JNK 15mar11 added section start ######################### ################# JNK 15mar11 added section start #########################
# JNK 06dec00 -- edited from PDL::Graphics/TriD/GObject in file Objects.pm # JNK 06dec00 -- edited from PDL::Graphics/TriD/GObject in file Objects.pm
# GObjects can be either stand-alone or in Graphs, scaled properly. # GObjects can be either stand-alone or in Graphs, scaled properly.
# All the points used by the object must be in the member {Points}. # All the points used by the object must be in the member {Points}.
# I guess we can afford to force data to be copied (X,Y,Z) -> (Points)... # I guess we can afford to force data to be copied (X,Y,Z) -> (Points)...
# JNK: I don't like that last assumption for all cases.. # JNK: I don't like that last assumption for all cases..
# JNK 27nov00 new object type: # JNK 27nov00 new object type:
package PDL::Graphics::TriD::GPObject; package PDL::Graphics::TriD::GPObject;
use base qw/PDL::Graphics::TriD::GObject/; use base qw/PDL::Graphics::TriD::GObject/;
sub new { sub new {
my($type,$points,$faceidx,$colors,$options) = @_; my($type,$points,$faceidx,$colors,$options) = @_;
# faceidx is 2D pdl of indices into points for each face # faceidx is 2D pdl of indices into points for each face
if(!defined $options and ref $colors eq "HASH") { if(!defined $options and ref $colors eq "HASH") {
$options = $colors;undef $colors; } $options = $colors;undef $colors; }
$points = PDL::Graphics::TriD::realcoords($type->r_type,$points); $points = PDL::Graphics::TriD::realcoords($type->r_type,$points);
my $faces = $points->dice_axis(1,$faceidx->clump(-1))->splitdim(1,3); my $faces = $points->dice_axis(1,$faceidx->clump(-1))->splitdim(1,3);
# faces is 3D pdl slices of points, giving cart coords of face verts # faces is 3D pdl slices of points, giving cart coords of face verts
if(!defined $colors) { $colors = PDL->pdl(1,1,1); if(!defined $colors) { $colors = PDL->pdl(1,1,1);
$colors = $type->cdummies($colors,$faces); $colors = $type->cdummies($colors,$faces);
$options->{ UseDefcols } = 1; } # for VRML efficiency $options->{ UseDefcols } = 1; } # for VRML efficiency
else { $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); } else { $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); }
my $this = bless { Points => $points, Faceidx => $faceidx, Faces => $faces, my $this = bless { Points => $points, Faceidx => $faceidx, Faces => $faces,
Colors => $colors, Options => $options},$type; Colors => $colors, Options => $options},$type;
$this->check_options();return $this; $this->check_options;
$this;
} }
sub get_valid_options { { UseDefcols=>0, Lines=>0, Smooth=>1 } }
sub get_valid_options {
return { UseDefcols=>0, Lines=>0, Smooth=>1, Material=>0 }; }
sub cdummies { sub cdummies {
return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); }
# JNK 13dec00 new object type: # JNK 13dec00 new object type:
package PDL::Graphics::TriD::STrigrid_S; package PDL::Graphics::TriD::STrigrid_S;
use base qw/PDL::Graphics::TriD::GPObject/; use base qw/PDL::Graphics::TriD::GPObject/;
sub cdummies { sub cdummies {
return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); }
sub new {
sub get_valid_options { my ($class,$points,$faceidx,$colors,$options) = @_;
return { UseDefcols=>0, Lines=>0, Smooth=>1, Material=>0 }; } my $this = $class->SUPER::new($points,$faceidx,$colors,$options);
$this->{Normals} //= $this->smoothn($this->{Points}) if $this->{Options}{Smoot
h};
$this;
}
# calculate smooth normals # calculate smooth normals
sub smoothn { my ($this,$ddd) = @_; sub smoothn { my ($this,$ddd) = @_;
my $v=$this->{Points};my $f=$this->{Faces};my $fvi=$this->{Faceidx}; my $v=$this->{Points};my $f=$this->{Faces};my $fvi=$this->{Faceidx};
# ---------------------------------------------------------------------------- # ----------------------------------------------------------------------------
my @p = map { $f->slice(":,($_),:") } (0..(($fvi->dims)[0]-1)); my @p = map { $f->slice(":,($_),:") } (0..(($fvi->dims)[0]-1));
# ---------------------------------------------------------------------------- # ----------------------------------------------------------------------------
# the following line assumes all faces are triangles # the following line assumes all faces are triangles
my $fn = ($p[1]-$p[0])->crossp($p[2]-$p[1])->norm; my $fn = ($p[1]-$p[0])->crossp($p[2]-$p[1])->norm;
# my $vfi = PDL::cat(map {PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)')} # my $vfi = PDL::cat(map {PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)')}
# (0..(($v->dims)[1]-1))); # (0..(($v->dims)[1]-1)));
skipping to change at line 193 skipping to change at line 179
# my @vfi0=PDL::whichND($fvi==$idx); # my @vfi0=PDL::whichND($fvi==$idx);
# my $vfi1=PDL::cat(@vfi0); # my $vfi1=PDL::cat(@vfi0);
# $vfi2[$idx]=$vfi1->slice(':,(1)'); } # $vfi2[$idx]=$vfi1->slice(':,(1)'); }
# my $vfi=PDL::cat(@vfi2); # my $vfi=PDL::cat(@vfi2);
# my $vmn = $fn->dice_axis(1,$vfi->clump(-1))->splitdim(1,($fvi->dims)[0]); # my $vmn = $fn->dice_axis(1,$vfi->clump(-1))->splitdim(1,($fvi->dims)[0]);
# my $vn = $vmn->mv(1,0)->sumover->norm; # my $vn = $vmn->mv(1,0)->sumover->norm;
# ---------------------------------------------------------------------------- # ----------------------------------------------------------------------------
my $vn=PDL::cat( my $vn=PDL::cat(
map { my $vfi=PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)'); map { my $vfi=PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)');
$fn->dice_axis(1,$vfi)->mv(1,0)->sumover->norm } $fn->dice_axis(1,$vfi)->mv(1,0)->sumover->norm }
(0..(($v->dims)[1]-1)) ); 0..($v->dim(1)-1) );
# ---------------------------------------------------------------------------- # ----------------------------------------------------------------------------
return $vn; } return $vn;
}
# JNK 06dec00 new object type: # JNK 06dec00 new object type:
package PDL::Graphics::TriD::STrigrid; package PDL::Graphics::TriD::STrigrid;
use base qw/PDL::Graphics::TriD::GPObject/; use base qw/PDL::Graphics::TriD::GPObject/;
sub cdummies { # copied from SLattice_S; not yet modified... sub cdummies { # copied from SLattice_S; not yet modified...
# called with (type,colors,faces) # called with (type,colors,faces)
return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); }
sub get_valid_options { { UseDefcols => 0, Lines => 1, Smooth => 1 } }
sub get_valid_options { # copied from SLattice_S; not yet modified...
return { UseDefcols => 0, Lines => 1, Smooth => 0, Material => 0 }; }
################# JNK 15mar11 added section finis ######################### ################# JNK 15mar11 added section finis #########################
########################################################################### ###########################################################################
package PDL::Graphics::TriD::Lattice;
use base qw/PDL::Graphics::TriD::GObject/;
sub r_type {return "SURF2D";}
sub cdummies { return $_[1]->dummy(1)->dummy(1); }
package PDL::Graphics::TriD::Lines;
use base qw/PDL::Graphics::TriD::GObject/;
sub cdummies { return $_[1]->dummy(1); }
sub r_type { return "SURF2D";}
sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; }
package PDL::Graphics::TriD::LineStrip;
use base qw/PDL::Graphics::TriD::GObject/;
sub cdummies { return $_[1]->dummy(1); }
sub r_type { return "SURF2D";}
sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; }
package PDL::Graphics::TriD::GObject_Lattice; package PDL::Graphics::TriD::GObject_Lattice;
use base qw/PDL::Graphics::TriD::GObject/; use base qw/PDL::Graphics::TriD::GObject/;
sub r_type {return "SURF2D";} sub r_type {return "SURF2D";}
sub get_valid_options { return {UseDefcols => 0,Lines => 1}; } sub get_valid_options { return {UseDefcols => 0,Lines => 1}; }
# colors associated with vertices, smooth package PDL::Graphics::TriD::Lattice;
package PDL::Graphics::TriD::SLattice;
use base qw/PDL::Graphics::TriD::GObject_Lattice/; use base qw/PDL::Graphics::TriD::GObject_Lattice/;
sub cdummies { return $_[1]->dummy(1)->dummy(1); }
sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2))
-> dummy(1,$_[2]->getdim(1)); }
# colors associated with surfaces # colors associated with surfaces
package PDL::Graphics::TriD::SCLattice; package PDL::Graphics::TriD::SCLattice;
use base qw/PDL::Graphics::TriD::GObject_Lattice/; use base qw/PDL::Graphics::TriD::GObject_Lattice/;
sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)-1) sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)-1)
-> dummy(1,$_[2]->getdim(1)-1); } -> dummy(1,$_[2]->getdim(1)-1); }
# colors associated with vertices # colors associated with vertices, smooth
package PDL::Graphics::TriD::SLattice_S; package PDL::Graphics::TriD::SLattice;
use base qw/PDL::Graphics::TriD::GObject_Lattice/; use base qw/PDL::Graphics::TriD::GObject_Lattice/;
use fields qw/Normals/;
sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)) sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2))
-> dummy(1,$_[2]->getdim(1)); } -> dummy(1,$_[2]->getdim(1)); }
sub get_valid_options { return {UseDefcols => 0,Lines => 1, Smooth => 0, # colors associated with vertices
Material => 0}; } package PDL::Graphics::TriD::SLattice_S;
use base qw/PDL::Graphics::TriD::GObject_Lattice/;
use fields qw/Normals/;
sub cdummies {
$_[1]->slice(":," . join ',', map "*$_", ($_[2]->dims)[1,2])
}
sub get_valid_options {
{UseDefcols => 0,Lines => 1, Smooth => 1}
}
sub new {
my ($class,$points,$colors,$options) = @_;
my $this = $class->SUPER::new($points,$colors,$options);
$this->{Normals} //= $this->smoothn($this->{Points}) if $this->{Options}{Smoot
h};
$this;
}
# calculate smooth normals # calculate smooth normals
sub smoothn { sub smoothn {
my ($this,$p) = @_; my ($this,$p) = @_;
# coords of parallel sides (left and right via 'lags') # coords of parallel sides (left and right via 'lags')
my $trip = $p->lags(1,1,2)->slice(':,:,:,1:-1') - my $trip = $p->lags(1,1,2)->slice(':,:,:,1:-1') -
$p->lags(1,1,2)->slice(':,:,:,0:-2'); $p->lags(1,1,2)->slice(':,:,:,0:-2');
# coords of diagonals with dim 2 having original and reflected diags # coords of diagonals with dim 2 having original and reflected diags
my $tmp; my $tmp;
my $trid = ($p->slice(':,0:-2,1:-1')-$p->slice(':,1:-1,0:-2')) my $trid = ($p->slice(':,0:-2,1:-1')-$p->slice(':,1:-1,0:-2'))
->dummy(2,2); ->dummy(2,2);
# $ortho is a (3D,x-1,left/right triangle,y-1) array that enumerates # $ortho is a (3D,x-1,left/right triangle,y-1) array that enumerates
# all triangles # all triangles
my $ortho = $trip->crossp($trid); my $ortho = $trip->crossp($trid);
$ortho->norm($ortho); # normalise inplace $ortho->norm($ortho); # normalise inplace
# now add to vertices to smooth # now add to vertices to smooth
my $aver = ref($p)->zeroes($p->dims); my $aver = ref($p)->zeroes($p->dims);
# step 1, upper right tri0, upper left tri1 # step 1, upper right tri0, upper left tri1
($tmp=$aver->lags(1,1,2)->slice(':,:,:,1:-1')) += $ortho; ($tmp=$aver->lags(1,1,2)->slice(':,:,:,1:-1')) += $ortho;
# step 2, lower right tri0, lower left tri1 # step 2, lower right tri0, lower left tri1
($tmp=$aver->lags(1,1,2)->slice(':,:,:,0:-2')) += $ortho; ($tmp=$aver->lags(1,1,2)->slice(':,:,:,0:-2')) += $ortho;
# step 3, upper left tri0 # step 3, upper left tri0
($tmp=$aver->slice(':,0:-2,1:-1')) += $ortho->slice(':,:,(0)'); ($tmp=$aver->slice(':,0:-2,1:-1')) += $ortho->slice(':,:,(0)');
# step 4, lower right tri1 # step 4, lower right tri1
($tmp=$aver->slice(':,1:-1,0:-2')) += $ortho->slice(':,:,(1)'); ($tmp=$aver->slice(':,1:-1,0:-2')) += $ortho->slice(':,:,(1)');
 End of changes. 32 change blocks. 
104 lines changed or deleted 68 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)