layout/slopecalc

   1 #!/usr/bin/perl -w
   2 #
   3 # usage:
   4 #   slopecalc =HEIGHT|SLOPE%|+DIST|@ABSDIST ...
   5 #     ... | atp -B >ps
   6 #
   7 # args represent details of control points
   8 #
   9 # an arg starts a new control point if it specifies
  10 #  a property (height, slope or location) which has
  11 #  already been determined for the current control
  12 #  point.
  13 #
  14 # when a new point is started all the properties of the previous
  15 #  point must be determinable - although unless otherwise specified
  16 #  the slope will remain unchanged from the point before, and if
  17 #  the slope _has_ changed a default distance is supplied
  18 #
  19 # the first use of @... to specify an absolute location
  20 #  acts only to fix the zero point of the absolute position scale;
  21 #  the (relative to start) location of the current point must already be known
  22
  23 use strict qw(vars refs);
  24
  25 our $halfreverselen= 80; # mm to change from going flat to going up/down
  26 our $printinterval= 10;
  27 our $totallinesout= 139;
  28
  29 our @cp= ({ L => 0 });
  30 # $cp[]{H}    height
  31 # $cp[]{L}    absolute dist
  32 # $cp[]{S}    slope
  33 our $absoffset;
  34
  35 our $numre= '(?:\\d{1,6}(?:\\.\\d*)?|\\.\\d+)';
  36
  37 our $progname= $0;
  38 $progname =~ s,.*/,,;
  39 our $arg_errors= 0;
  40 our $lines++;
  41
  42 sub arg_error ($) {
  43     my ($m) = @_;
  44     print STDERR "$progname: $m\n";
  45     $arg_errors++;
  46 }
  47
  48 sub lprintf {
  49     printf @_ or die $!;
  50     print "\n" or die $!;
  51     $lines++;
  52 }
  53
  54 # always called in this order:         $this->{S}   $this->{L}   $this->{H}
  55 #  compute_fixed_S($last,$this)        undef         -            -
  56 #  compute_fixed_L($last,$this)         -           undef         -
  57 #  compute_fixed_H($last,$this)         -            -           undef
  58 #  compute_default_S($last,$this)      undef         -            -
  59 #  compute_default_L($last,$this)      defined      undef         -
  60 #  compute_default_H($last,$this)      defined      defined      undef
  61 # $last->{S}, $last->{H}, $last->{L} are always defined on entry
  62
  63 sub compute_fixed_S ($$) { }
  64 sub compute_default_S ($$) {
  65     my ($last,$this) = @_;
  66     $this->{S}= $last->{S};
  67 }
  68 sub compute_fixed_L ($$) {
  69     my ($last,$this) = @_;
  70     if (defined $this->{S}
  71         and defined $this->{H}
  72         and $last->{S} == $this->{S}) {
  73         $this->{L}= $last->{L} + ($this->{H} - $last->{H})/$last->{S};
  74         return;
  75     }
  76 }
  77 sub compute_default_L ($$) {
  78     my ($last,$this) = @_;
  79     if (defined $this->{S}
  80         and !defined $this->{H}
  81         and $last->{S} != $this->{S}) {
  82         $this->{L}= $last->{L} +
  83             $halfreverselen * ($last->{S} * $this->{S} < 0 ? 2 : 1);
  84         return;
  85     }
  86 }
  87 sub compute_fixed_H ($$) {
  88     my ($last,$this) = @_;
  89     if (defined $this->{S}
  90         and defined $this->{L}) {
  91         my $meanslope= 0.5 * ($last->{S} + $this->{S});
  92         $this->{H}= $last->{H} + $meanslope * ($this->{L} - $last->{L});
  93         return;
  94     }
  95 }
  96 sub compute_default_H ($$) { }
  97
  98 sub complete_current_point ($) {
  99     my ($why) = @_;
 100     my $say_why= 0;
 101
 102     my $this= $cp[$#cp];
 103     my $last= @cp > 1 ? $cp[$#cp-1] : undef;
 104     foreach my $k2 (qw(S L H)) {
 105         if (defined $last) {
 106             no strict 'refs';
 107             defined $this->{$k2} or &{"compute_fixed_$k2"}($last, $this);
 108             defined $this->{$k2} or &{"compute_default_$k2"}($last, $this);
 109         }
 110         if (!defined $this->{$k2}) {
 111             arg_error("point \#$#cp: property $k2 unspecified");
 112             $this->{$k2}= 1;
 113             $say_why= 1;
 114         }
 115     }
 116     if ($say_why) {
 117         print STDERR "$progname: ($why)\n"
 118             or die $!;
 119     }
 120 }
 121
 122 sub arg_item ($$) {
 123     my ($k, $v) = @_;
 124     my $last = $cp[$#cp];
 125
 126     if (!defined $last->{$k}) {
 127         $last->{$k}= $v;
 128         return;
 129     }
 130     complete_current_point("new point started because of change to $k");
 131     my $this = { $k => $v };
 132     foreach my $k2 (qw(S L H)) {
 133         no strict 'refs';
 134         defined $this->{$k2} or &{"compute_fixed_$k"}($last, $this);
 135     }
 136     push @cp, $this;
 137 }
 138
 139 #use Data::Dumper;
 140
 141 sub parse_args () {
 142     foreach $_ (@ARGV) {
 143 #print STDERR ">$_<\n", Dumper(\@cp);
 144         if (m/^\=([-+]?$numre)$/o) {
 145             arg_item(H, $1);
 146         } elsif (m/^([-+]?$numre)\%$/o) {
 147             arg_item(S, $1 * 0.01);
 148         } elsif (m/^([-+]?1)\:($numre)$/o) {
 149             arg_item(S, $1 / $2);
 150         } elsif (m/^\@([-+]?$numre)$/o) {
 151             if (defined $absoffset) {
 152                arg_item(L, $1 + $absoffset);
 153            } else {
 154                if (!@cp) {
 155                    $absoffset= -$1;
 156                } elsif (defined $cp[$#cp]{L}) {
 157                    $absoffset= $cp[$#cp]{L} - $1;
 158                } else {
 159                    arg_error("point \#$#cp location still unknown at \`$_'");
 160                }
 161            }
 162         } elsif (m/^\+($numre)$/o) {
 163             complete_current_point("new point started because of +...");
 164             arg_item(L, $cp[$#cp]{L} + $1);
 165         } else {
 166             arg_error("bad argument `$_'");
 167         }
 168         push @{ $cp[$#cp]{Args} }, $_;
 169     }
 170     complete_current_point("completing as it is the final point");
 171     die "$progname: errors in argument(s)\n" if $arg_errors;
 172 }
 173
 174 sub lprint_interp ($$$$) {
 175     my ($l_more,$l,$y,$cc) = @_;
 176     lprintf("   %4s        %7d  %8.2f  %s",
 177             "+$l_more", $l - $absoffset, $y, $cc);
 178 }
 179
 180 sub dump_schedule ($) {
 181     my ($interpolate) = @_;
 182     $absoffset=0 unless defined $absoffset;
 183     my $i;
 184     my $last_l= 0;
 185     my $last_h;
 186     my $last;
 187     for ($i=0; $i<@cp; $i++) {
 188         my $this= $cp[$i];
 189         lprintf("%4s  %7s  %7s   =%6.2f  %s %5.02f%%   %s   %s",
 190                 "#$i",
 191                 '+'.($this->{L} - $last_l),
 192                 '@'.($this->{L} - $absoffset),
 193                 $this->{H},
 194                 ($this->{S} < 0 ? '/' :
 195                  $this->{S} > 0 ? '\\' :
 196                  '|'),
 197                 $this->{S} * 100,
 198                 (defined $last_h ?
 199                  sprintf "=%+6.2f", $this->{H} - $last_h :
 200                  '       '),
 201                 "@{ $this->{Args} }");
 202         my $next= $cp[$i+1];
 203         if ($interpolate and defined $next) {
 204             my $more_l= 0;
 205             my $dist_l = $next->{L} - $this->{L};
 206             if ($dist_l > 0) {
 207                 my $base_hdiff = $next->{H} - $this->{H};
 208                 my $base_slope = $base_hdiff / $dist_l;
 209                 my $next_hoop = -($next->{S} * $dist_l - $base_hdiff);
 210                 my $this_hoop =   $this->{S} * $dist_l - $base_hdiff;
 211                 my $char_char =
 212                     ($next->{S} < $this->{S} ? '>' :
 213                      $next->{S} > $this->{S} ? '<' :
 214                      $next->{H} < $this->{H} ? '/' :
 215                      $next->{H} > $this->{H} ? '\\' :
 216                      '|');
 217                 for (;;) {
 218                     $more_l += $printinterval;
 219                     my $gamma= $more_l / $dist_l;
 220                     my $l = $this->{L} + $more_l;
 221                     last unless $l < $next->{L};
 222                     my $zeta= 1 - $gamma;
 223                     my $y = $this->{H} + $gamma * $base_hdiff;
 224                     my $hoop= $gamma * $zeta;
 225                     $y += $hoop * ($gamma * $next_hoop +
 226                                    $zeta * $this_hoop);
 227                     lprint_interp($more_l,$l,$y,$char_char);
 228                 }
 229             }
 230         }
 231         $last_l= $this->{L};
 232         $last_h= $this->{H};
 233         $last= $this;
 234     }
 235     if ($interpolate) {
 236         my $more_l= 0;
 237         while ($lines+2 < $totallinesout) {
 238             lprint_interp($more_l,
 239                           $last->{L} + $more_l,
 240                           $last->{H} + $last->{S} * $more_l,
 241                           ':');
 242             $more_l += $printinterval;
 243         }
 244     }
 245 }
 246 parse_args();
 247
 248 sub dump_args () {
 249     my @out;
 250     my $lmax= 78;
 251     my $xpos= -1;
 252
 253     lprintf("args:");
 254     lprintf("");
 255
 256     my $writeout= sub {
 257         foreach my $oi (0..2) {
 258             lprintf(" %s",
 259                     join(($oi==1 ? '|' : ' '),
 260                          @{ $out[$oi] }));
 261         }
 262     };
 263     my $push= sub {
 264         $xpos += 1 + length($_[0]);
 265         if ($xpos >= $lmax) {
 266             foreach my $oi (0..2) {
 267                 push @{ $out[$oi] },
 268                     ($oi==1 && $_[$oi] =~ m/^\-/ ? '-' : '');
 269             }
 270             $writeout->();
 271             lprintf('');
 272             @out= ();
 273             $xpos= length($_[0]);
 274         }
 275         foreach my $oi (0..2) {
 276             push @{ $out[$oi] }, $_[$oi];
 277         }
 278     };
 279
 280     foreach (my $i=0; $i<@cp; $i++) {
 281         my $cp= $cp[$i];
 282         my @iargs= @{ $cp->{Args} };
 283
 284         if (@iargs && $iargs[0] =~ m/^\+$numre$/) {
 285             my $relmove= shift @iargs;
 286             $push->($relmove,
 287                     '-'x length $relmove,
 288                     ' 'x length $relmove);
 289         } elsif ($i) {
 290             $push->(' ',
 291                     '-',
 292                     ' ');
 293         }
 294
 295         my $ipoint= "#$i";
 296         my $lipoint= length $ipoint;
 297         my $iargs= "@iargs";
 298         my $lip= $lipoint;
 299         my $l= $lipoint > length($iargs) ? $lipoint : length($iargs);
 300
 301         my $pad= int(($l-$lipoint)/2);
 302
 303         $push->((sprintf "%-*s", $l, $iargs),
 304                 ' 'x $l,
 305                 (' 'x $pad). $ipoint. (' ' x ($l-$lipoint-$pad)));
 306     }
 307     $writeout->();
 308 }
 309
 310 dump_args();
 311 lprintf("");
 312
 313 lprintf("control points:");
 314 dump_schedule(0);
 315 lprintf("");
 316 lprintf("table of heights:");
 317 dump_schedule(1);
 318
 319 my $dir= $0; $dir =~ s,/.*?$,,;
 320 my $gitid= `$dir/../.git-revid`; $? and die $?; chomp $gitid;
 321
 322 lprintf("");
 323 lprintf("%s",
 324        "\$Id: $gitid \$"
 325     );