::Triangles to also take \[$2dcolor,$texcoord] as colours, ::Lattice uses

Author: mohawk2

lib/PDL/Graphics/TriD/GL.pm

@@ -338,13 +338,18 @@ use OpenGL::Modern qw(
   glShadeModel glColorMaterial glEnable glDisable
   glDrawElements_c
   GL_FLAT GL_SMOOTH GL_FRONT_AND_BACK GL_DIFFUSE GL_COLOR_MATERIAL
-  GL_TRIANGLES GL_UNSIGNED_INT
+  GL_TRIANGLES GL_UNSIGNED_INT GL_RGB
 );
 sub togl_setup {
   my ($this,$points) = @_;
   print "togl_setup $this\n" if $PDL::Graphics::TriD::verbose;
   $this->load_buffer(vert_buf => $points);
-  $this->load_buffer(color_buf => $this->{Colors});
+  if (defined $this->{Colors}) {
+    $this->load_buffer(color_buf => $this->{Colors});
+  } else {
+    $this->load_buffer(texc_buf => $this->{TexCoord});
+    $this->load_texture(tex_id => $this->{TexColors}, GL_RGB, ($this->{TexColors}->dims)[1,2], GL_RGB);
+  }
   $this->load_idx_buffer(indx_buf => $this->{Faceidx});
   $this->load_buffer(norm_buf => $this->{Normals}) if $this->{Options}{Shading} > 2;
   $this->togl_unbind;

lib/PDL/Graphics/TriD/Object.pm

@@ -19,6 +19,17 @@ sub new {
 
 sub normalise_as {
   my ($this, $as, $what, $points) = @_;
+  if (ref $what eq 'REF') {
+    die "Given scalar-ref but not as 'COLOR'" if $as ne "COLOR";
+    die "Given scalar-ref as 'COLOR' but not to array-ref" if ref $$what ne 'ARRAY';
+    die "Given \\[...] as 'COLOR' but not 2 elts" if @$$what != 2;
+    die "Given \\[\$x,\$y] as 'COLOR' but at least one is not ndarray" if grep !UNIVERSAL::isa($_, 'PDL'), @$$what;
+    my @xdims = $$what->[0]->dims;
+    die "Given \\[\$x,\$y] as 'COLOR' but \$x is not float(3,x,y)" if @xdims != 3 or $xdims[0] != 3 or $$what->[0]->type ne 'float';
+    my @ydims = $$what->[1]->dims;
+    die "Given \\[\$x,\$y] as 'COLOR' but \$y is not float(2,...)" if @ydims < 2 or $ydims[0] != 2 or $$what->[1]->type ne 'float';
+    return $what;
+  }
   if ($as eq "COLOR" and UNIVERSAL::isa($what, 'PDL') and $what->ndims == 1) {
     die "Given 1D ndarray as colour but no points to match" if !defined $points;
     return $this->cdummies($what->float,$points);

lib/PDL/Graphics/TriD/Objects.pm

@@ -175,15 +175,20 @@ sub cdummies { $_[1]->dummy(1,$_[2]->getdim(1)); }
 package # hide from PAUSE
   PDL::Graphics::TriD::Triangles;
 use base qw/PDL::Graphics::TriD::GObject/;
-use fields qw/Faceidx Normals/;
+use fields qw/Faceidx Normals TexColors TexCoord/;
 use PDL::Graphics::OpenGLQ;
 sub new {
   my $options = ref($_[-1]) eq 'HASH' ? pop : {};
   my ($type,$points,$faceidx,$colors) = @_;
   my $this = $type->SUPER::new($points,$colors,$options);
   $faceidx = $this->{Faceidx} = $faceidx->ulong; # (3,nfaces) indices
-  PDL::barf "Triangles error: broadcast dimensions forbidden for '$_' [@{[$this->{$_}->dims]}]" for grep $this->{$_}->ndims != 2, qw(Points Colors Faceidx);
-  PDL::barf "Triangles error: dimension mismatch between Points [@{[$this->{Points}->dims]}] and Colors [@{[$this->{Colors}->dims]}]" if $this->{Points}->ndims != $this->{Colors}->ndims or $this->{Points}->dim(1) != $this->{Colors}->dim(1);
+  if (ref $this->{Colors} eq 'REF') {
+    @$this{qw(TexColors TexCoord)} = @${ $this->{Colors} };
+    $this->{Colors} = undef;
+  }
+  PDL::barf "Triangles error: broadcast dimensions forbidden for '$_' [@{[$this->{$_}->dims]}]" for grep defined $this->{$_} && $this->{$_}->ndims != 2, qw(Points Colors Faceidx TexCoord);
+  my ($colour_cmp) = grep defined, @$this{qw(Colors TexCoord)};
+  PDL::barf "Triangles error: dimension mismatch between Points [@{[$this->{Points}->dims]}] and Colors/TexCoord [@{[$colour_cmp->dims]}]" if $this->{Points}->ndims != $colour_cmp->ndims or $this->{Points}->dim(1) != $colour_cmp->dim(1);
   $options = $this->{Options};
   my ($idxflat, $idx0, @idxdims) = ($faceidx->flat, $faceidx->dims);
   if ($options->{Shading} or $options->{ShowNormals}) {
@@ -264,7 +269,10 @@ sub new {
     my @colordims = $colors->dims;
     PDL::barf "Lattice: colours must be 3,x,y: got (@colordims)" if @colordims != 3 or $colordims[0] != 3;
     PDL::barf "Lattice: colours' x,y must equal points: got colour=(@colordims) points=($x,$y)" if $colordims[1] != $x or $colordims[2] != $y;
-    $this->add_object(PDL::Graphics::TriD::Triangles->new($points->clump(1..2), $faceidx, $colors->clump(1..$colors->ndims-1), \%less));
+    my $tc = PDL->zeroes(PDL::float, 2, @colordims[1,2]);
+    $tc->slice('(0)') .= $tc->slice('(0)')->xlinvals(0,1); # should be inplace but PDL bugfix not yet released XXX
+    $tc->slice('(1)') .= $tc->slice('(1)')->ylinvals(0,1);
+    $this->add_object(PDL::Graphics::TriD::Triangles->new($points->clump(1..2), $faceidx, \[$colors, $tc->clump(1..2)], \%less));
   }
   if ($shading == 0 or $options->{Lines}) {
     my $lcolors = $shading ? $this->cdummies(PDL::float(0,0,0),$points) : $colors;