"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.080/IO/STL/STL.pm" (19 May 2022, 7254 Bytes) of package /linux/misc/PDL-2.080.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "STL.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.079_vs_2.080.

    1 package PDL::IO::STL;
    2 
    3 use strict;
    4 use warnings;
    5 
    6 our $VERSION = '0.001';
    7 our @EXPORT_OK = qw( rstl wstl );
    8 our %EXPORT_TAGS = (Func=>[@EXPORT_OK]);
    9 our @ISA = ('PDL::Exporter');
   10 
   11 use PDL::LiteF;
   12 use PDL::Options;
   13 use PDL::Exporter;
   14 use PDL::IO::Misc; # for little/big-endian
   15 
   16 =head1 NAME
   17 
   18 PDL::IO::STL - read/write 3D stereolithography files
   19 
   20 =head1 SYNOPSIS
   21 
   22  use PDL;
   23  use PDL::IO::STL;
   24 
   25  ($vertices, $faceidx, $colours) = rstl('owl.stl'); # read an STL file
   26  wstl('file.stl', $vertices, $faceidx, $colours); # write an STL file
   27 
   28 =head1 DESCRIPTION
   29 
   30 Normal-vector information is currently ignored.
   31 The "attribute byte count", used sometimes to store colour information,
   32 is currently ignored.
   33 
   34 This module is based on L<CAD::Format::STL>, but with C<binmode> on
   35 opened filehandles and little-endian (i.e. network) order forced on the
   36 binary format.
   37 
   38 =head1 FUNCTIONS
   39 
   40 =head2 rstl
   41 
   42 =for ref
   43 
   44 Read an STL file (ASCII or binary), returning vertices and face-indices.
   45 
   46 =for example
   47 
   48  ($vertices, $faceidx, $colours) = rstl('owl.stl'); # read an STL file
   49 
   50 =cut
   51 
   52 sub rstl { PDL->rstl(@_); }
   53 sub PDL::rstl {
   54   my $class = shift;
   55   barf 'Usage: $x = rstl($file) -or- $x = PDL->rstl($file)' if @_ < 1 || @_ > 2;
   56   my $file = shift;
   57   # allow filehandle
   58   unless((ref($file) || '') eq 'GLOB') {
   59     open(my $fh, '<', $file) or
   60       barf "cannot open '$file' for reading $!";
   61     binmode $fh;
   62     $file = $fh;
   63   }
   64   barf('must have seekable filehandle') if !seek($file, 0,0);
   65   my $mode = _detect($file);
   66   seek($file, 0, 0) or barf "cannot reset filehandle";
   67   my $func = $mode eq 'ascii' ? \&_read_ascii : \&_read_binary;
   68   $func->($file);
   69 }
   70 
   71 sub _detect {
   72   my $fh = shift;
   73   my $location = tell $fh;
   74   my $buf; read($fh, $buf, 5) or barf $@;
   75   seek($fh, $location, 0), return 'ascii' if $buf eq 'solid';
   76   seek($fh, $location + 80, 0);
   77   my $count = eval {
   78     my $buf; read($fh, $buf, 4) or barf $@;
   79     unpack('L<', $buf);
   80   };
   81   $@ and seek($fh, $location, 0), return 'ascii'; # if we hit eof, not binary
   82   $count or barf "detection failed - no facets?";
   83   my $size = (stat($fh))[7];
   84   barf "failed to stat '$fh'" if !defined $size;
   85   # calculate the expected file size
   86   my $expect =
   87     + 80 # header
   88     +  4 # count
   89     + $count * (
   90       + 4 # normal, pt,pt,pt (vectors)
   91       * 3 # values per vector
   92       * 4 # bytes per value
   93       + 2 # the trailing 'short'
   94     );
   95   return ($size - $location >= $expect) ? 'binary' : 'ascii';
   96 }
   97 
   98 my $p_re = qr/([^ ]+)\s+([^ ]+)\s+([^ ]+)$/;
   99 sub _read_ascii {
  100   my ($fh) = @_;
  101   my $getline = sub {
  102     while(my $line = <$fh>) {
  103       $line =~ s/\s*$//; # allow any eol
  104       length($line) or next;
  105       return($line);
  106     }
  107     return;
  108   };
  109   my (@tri, $part);
  110   while(my $line = $getline->()) {
  111     if($line =~ m/^\s*solid (.*)/) {
  112       $part = $1;
  113       next;
  114     }
  115     elsif($line =~ m/^\s*endsolid (.*)/) {
  116       my $name = $1;
  117       barf "invalid 'endsolid' entry with no current part" if !defined $part;
  118       barf "end of part '$name' should have been '$part'" if $name ne $part;
  119       $part = undef;
  120       last;
  121     }
  122     barf "what? ($line)" if !defined $part;
  123     my @n = ($line =~ m/^\s*facet\s+normal\s+$p_re/) or
  124       barf "how did that happen? ($line)";
  125     my $next = $getline->();
  126     unless($next and ($next =~ m/^\s*outer\s+loop$/)) {
  127       barf "facet doesn't start with 'outer loop' ($next)";
  128     }
  129     my @this_tri;
  130     while(my $line = $getline->()) {
  131       ($line =~ m/^\s*endloop$/) and last;
  132       if($line =~ m/^\s*vertex\s+$p_re/) {
  133         push(@this_tri, [$1, $2, $3]);
  134       }
  135     }
  136     barf "need three vertices per facet (not @{[ 0+@this_tri ]})" if @this_tri != 3;
  137     my $end = $getline->();
  138     ($end and ($end =~ m/^\s*endfacet/)) or
  139       barf "bad endfacet $line";
  140     push @tri, \@this_tri;
  141   }
  142   barf "part '$part' was left open" if defined $part;
  143   _as_ndarray(pdl PDL::float(), \@tri);
  144 }
  145 
  146 sub _as_ndarray {
  147   my ($pdl) = @_;
  148   my $uniqv = $pdl->uniqvec;
  149   ($uniqv, $pdl->vsearchvec($uniqv), undef);
  150 }
  151 
  152 sub _read_binary {
  153   my ($fh) = @_;
  154   barf "bigfloat" unless(length(pack("f", 1)) == 4);
  155   # TODO try to read part name from header (up to \0)
  156   seek($fh, 80, 0);
  157   my $buf; read($fh, $buf, 4) or warn "EOF?"; my $triangles = unpack('L<', $buf);
  158   my $bytes = 50 * $triangles; # norm+3vertices * 3float + short with length of extra
  159   my $bytespdl = zeroes PDL::byte(), 50, $triangles;
  160   my $bytesread = read($fh, ${$bytespdl->get_dataref}, $bytes);
  161   barf "Tried to read $bytes but only got $bytesread" if $bytesread != $bytes;
  162   $bytespdl->upd_data;
  163   my $floatpdl = zeroes PDL::float(), 3, 4, $triangles;
  164   ${$floatpdl->get_dataref} = ${$bytespdl->slice('0:47')->get_dataref};
  165   $floatpdl->upd_data;
  166   $floatpdl->type->bswap->($floatpdl) if isbigendian();
  167   # TODO check that the unit normal is within a thousandth of a radian
  168   # (0.001 rad is ~0.06deg)
  169   _as_ndarray($floatpdl->slice(':,1:3'));
  170 }
  171 
  172 =head2 wstl
  173 
  174 =for ref
  175 
  176 Simple PDL FITS writer
  177 
  178 =for example
  179 
  180   wstl 'file.stl', $vertices, $faceidx;
  181   wstl 'file.stl', $vertices, $faceidx, \%OPTIONS;
  182   wstl $fh, $vertices, $faceidx, \%OPTIONS;
  183 
  184 Passing a file-handle is supported, so multiple parts can be written to
  185 an ASCII file with several calls.
  186 
  187 C<wstl> accepts several options that may be passed in as a hash ref
  188 if desired:
  189 
  190 =over 3
  191 
  192 =item mode (default='binary')
  193 
  194 Whether to write out the file as ASCII or binary.
  195 
  196 =item name (default='part')
  197 
  198 The part name to use.
  199 
  200 =back
  201 
  202 =cut
  203 
  204 our $wstl_options = PDL::Options->new( { mode=>'binary', name=>'part' } );
  205 my %valid_mode = map +($_=>1), qw(ascii binary);
  206 sub wstl { PDL->wstl(@_); }
  207 sub PDL::wstl {
  208   barf 'Usage: wstl($file,$vertices,$faceidx,[$colours],[{options}])' if @_<3 || @_>5;
  209   my (undef, $file, $v, $f, $c) = @_;
  210   my $u_opt = ifhref($_[-1]);
  211   my $opt = $wstl_options->options($u_opt);
  212   my $mode = $opt->{mode};
  213   barf "invalid write mode '$mode'" if !$valid_mode{$mode};
  214   # allow filehandle
  215   unless((ref($file) || '') eq 'GLOB') {
  216     open(my $fh, '>', $file) or
  217       barf "cannot open '$file' for writing $!";
  218     binmode $fh;
  219     $file = $fh;
  220   }
  221   my $func = $mode eq 'ascii' ? \&_write_ascii : \&_write_binary;
  222   $func->($file, $v, $f, $c, $opt->{name});
  223   1;
  224 }
  225 
  226 sub _write_binary {
  227   my ($fh, $v, $f, $c, $name) = @_;
  228   print $fh $name, "\0" x (80 - do {use bytes; length($name)});
  229   print $fh pack 'L<', $f->dim(1);
  230   foreach my $facet (@{ $v->dice_axis(1, $f->flat)->splitdim(1,3)->unpdl }) {
  231     print $fh map {map pack('f<', $_), @$_} [0,0,0], @$facet;
  232     print $fh "\0" x 2;
  233   }
  234 }
  235 
  236 sub _write_ascii {
  237   my ($fh, $v, $f, $c, $name) = @_;
  238   my $spaces = '';
  239   my $print = sub {print $fh $spaces . join(' ', @_) . "\n"};
  240   $print->('solid', $name);
  241   $spaces = ' 'x2;
  242   foreach my $facet (@{ $v->dice_axis(1, $f->flat)->splitdim(1,3)->unpdl }) {
  243     my ($n, @pts) = ([0,0,0], @$facet);
  244     $print->('facet normal', @$n);
  245     $spaces = ' 'x4;
  246     $print->('outer loop');
  247     $spaces = ' 'x6;
  248     (@pts == 3) or barf "invalid facet";
  249     foreach my $pt (@pts) {
  250       $print->('vertex', @$pt);
  251     }
  252     $spaces = ' 'x4;
  253     $print->('endloop');
  254     $spaces = ' 'x2;
  255     $print->('endfacet');
  256   }
  257   $spaces = '';
  258   $print->('endsolid', $name);
  259 }
  260 
  261 =head1 AUTHOR
  262 
  263 Ed J, based on Eric Wilhelm's code in L<CAD::Format::STL>.
  264 
  265 =cut
  266 
  267 1;