distort-stl

   1 #!/usr/bin/perl -w
   2 #
   3 # usage:
   4 #   ./distort-stl <INPUT >OUTPUT DISTORTION [PARAMS...] ...
   5 #
   6 # DISTORTIONs:
   7 #
   8 #   project-cylinder RADIUS
   9 #       projects the X-Z plane onto the cylinder of
  10 #           radius RADIUS with axis [0, 0, t]
  11 #       origin becomes [0, -RADIUS, 0]
  12 #       other planes of the input are projected onto smaller
  13 #           or larger cylinders accordingly
  14 #       probably a bad idea if
  15 #           object has any Y > RADIUS
  16 #           object has any |X| > tau / RADIUS
  17 #       technically, treats input as if it were
  18 #       polar-rectangular coords:
  19 #          Z' = Z; R' = Y + RADIUS; theta' = X / RADIUS
  20 #       and then converts back into cartesian
  21
  22 use strict;
  23 use autodie;
  24
  25 use File::Temp;
  26
  27 sub shift_arg () {
  28     die unless @ARGV;
  29     scalar shift @ARGV;
  30 }
  31
  32 sub pointmap_distortion {
  33     my ($x,$y,$z) = @_;
  34     my $radius = shift_arg;
  35     my $r = $y + $radius;
  36     my $theta = $x / $radius;
  37     return ($r * cos($theta),
  38             $r * sin($theta),
  39             $z);
  40 }
  41
  42 if (@ARGV && $ARGV[0] =~ m/^-/) {
  43     die "no options supported\n";
  44 }
  45
  46 my $itmp = new File::Temp;
  47 my $otmp = new File::Temp;
  48
  49 system "cat >$itmp";
  50
  51 my $admesh_stdout = '--write-ascii-stl /dev/fd/3 3>&1 >/dev/null';
  52
  53 open I, "admesh $admesh_stdout $itmp |";
  54
  55 our @saved_argv = @ARGV;
  56
  57 while (<I>) {
  58     @ARGV = @saved_argv;
  59     if (s/^\s+vertex\s+//) {
  60         my $lhs = $&;
  61         s/\s+$//;
  62         my @xyz = split /\s+/, $_;
  63         while (@ARGV) {
  64             my $op = shift_arg;
  65             @xyz = &{ $::{"pointmap_$op"} }( @xyz );
  66         }
  67         @xyz = map { sprintf "%.18g", $_ } @xyz;
  68         $_ = "$lhs@xyz\n";
  69     }
  70     print $otmp $_;
  71 }
  72
  73 close I;
  74 <I> if 0; # suppresses Name "main::I" used only once
  75
  76 flush $otmp;
  77
  78 system "admesh --normal-values $admesh_stdout $otmp";