layout/layout

   1 #!/usr/bin/perl -w
   2
   3 use POSIX;
   4
   5 # Data structures:
   6 #  $loc{$id}{X}
   7 #  $loc{$id}{Y}
   8 #  $loc{$id}{A}  may be undef
   9
  10 #$debug=1;
  11 open DEBUG, ($debug ? ">&2" : ">/dev/null") or die $!;
  12
  13 if ($debug) {
  14     select(DEBUG); $|=1;
  15     select(STDOUT); $|=1;
  16 }
  17
  18 sub canf ($$) {
  19     my ($converter,$defaulter)=@_;
  20     my ($spec,$v);
  21     return &$defaulter unless @al;
  22     $spec= shift @al;
  23     $v= &$converter($spec);
  24     dv('canf ','$spec',$spec, '$v',$v);
  25     return $v;
  26 }
  27 sub can ($) { my ($c)=@_; canf($c, sub { die "too few args"; }); }
  28 sub cano ($$) { my ($c,$def)=@_; canf($c, sub { return $def }); }
  29
  30 $pi= atan2(0,-1);
  31
  32 %units_len= qw(- mm  mm 1  cm 10  m 1000);
  33 %units_ang= qw(- d   r 1); $units_ang{'d'}= 2*$pi / 360;
  34
  35 sub cva_len ($) { my ($sp)=@_; cva_units($sp,\%units_len); }
  36 sub cva_ang ($) { my ($sp)=@_; cva_units($sp,\%units_ang); }
  37 sub cva_units ($$) {
  38     my ($sp,$ua)=@_;
  39     my ($n,$u,$r);
  40     $sp =~ m/^([-0-9eE.]*[0-9.])([A-Za-z]*)$/
  41         or die "lexically invalid quantity";
  42     ($n,$u)= ($1,$2);
  43     $u=$ua->{'-'} unless length $u;
  44     defined $ua->{$u} or die "unknown unit $u";
  45     $r= $n * $ua->{$u};
  46     print DEBUG "cva_units($sp,)=$r ($n $u $ua->{$u})\n";
  47     return $r;
  48 }
  49 sub cva_idstr ($) {
  50     my ($sp)=@_;
  51     die "invalid id" unless $sp =~ m/^[-0-9a-z]+$/;
  52     return $&;
  53 }
  54 sub cva_idex ($) {
  55     my ($sp,$id)=@_;
  56     my ($r,$d,$k);
  57     $id=cva_idstr($sp);
  58     die "unknown $id" unless defined $loc{$id};
  59     $r= $loc{$id};
  60     $d= "idex $id";
  61     foreach $k (sort keys %$r) { $d .= " $k=$r->{$k}"; }
  62     printf DEBUG "%s\n", $d;
  63     return $r;
  64 }
  65 sub cva_idnew ($) {
  66     my ($sp,$id)=@_;
  67     $id=cva_idstr($sp);
  68     die "duplicate $id" if exists $loc{$id};
  69     exists $loc{$id}{X};
  70     return $loc{$id};
  71 }
  72 sub cva_cmd ($) {
  73     my ($sp)=@_;
  74     die "command lexically invalid" if $sp =~ m/[^-0-9a-z]/i;
  75     $sp =~ y/-/_/;
  76     return $sp;
  77 }
  78 sub cva__enum ($$) {
  79     my ($sp,$el)=@_;
  80     return $sp if grep { $_ eq $sp } @$el;
  81     die "invalid option (permitted: @$el)";
  82 }
  83 sub cvam_enum { my (@e) = @_; return sub { cva__enum($_[0],\@e); }; }
  84
  85 sub cmd_mark {
  86     $mark= 1;
  87     &cmd__do;
  88 }
  89
  90 sub cmd_abs {
  91     $nl= can(\&cva_idnew);
  92     $nl->{X}= can(\&cva_len);
  93     $nl->{Y}= can(\&cva_len);
  94     $nl->{A}= cano(\&cva_ang, undef);
  95 dv('cmd_abs ','$nl',$nl,'\\%loc',\%loc);
  96 }
  97
  98 sub cmd_rel {
  99     $from= can(\&cva_idex);
 100     $to= can(\&cva_idnew);
 101     $len= can(\&cva_len);
 102     $right= can(\&cva_len);
 103     $turn= cano(\&cva_ang, 0);
 104     $to->{X}= $from->{X} + $len * cos($from->{A}) + $right * sin($from->{A});
 105     $to->{Y}= $from->{Y} + $len * sin($from->{A}) - $right * cos($from->{A});
 106     $to->{A}= $from->{A} + $turn;
 107 dv('cmd_abs ','$to',$to);
 108 }
 109
 110 sub evreff ($) {
 111     my ($pfx) = @_;
 112     $pfx . ($pfx =~ m/\}$|\]$/ ? '' : '->');
 113 }
 114 sub evr ($) {
 115     my ($v) = @_;
 116     return $v if $v !~ m/\W/ && $v =~ m/[A-Z]/ && $v =~ m/^[a-z_]/i;
 117     return $v if $v eq ($v+0.0);
 118     $v =~ s/[\\\']/\\$&/g;
 119     return "'$v'";
 120 }
 121 sub dv1 ($$$);
 122 sub dv1_kind ($$$$$$$) {
 123     my ($pfx,$expr,$ref,$ref_exp,$ixfmt,$ixesfn,$ixmapfn) = @_;
 124     my ($ix,$any);
 125     return 0 if $ref ne $ref_exp;
 126     $any=0;
 127     foreach $ix (&$ixesfn) {
 128         $any=1;
 129         my ($v)= &$ixmapfn($ix);
 130 #print STDERR "dv1_kind($pfx,$expr,$ref,$ref_exp,$ixmapfn) ix=$ix v=$v\n";
 131         dv1($pfx,$expr.sprintf($ixfmt,evr($ix)),$v);
 132     }
 133     if (!$any) {
 134         printf DEBUG "%s%s= $ixfmt\n", $pfx, $expr, ' ';
 135     }
 136     1;
 137 }
 138 sub dv1 ($$$) {
 139     return ;0 unless $debug;
 140     my ($pfx,$expr,$v) = @_;
 141     $ref= ref $v;
 142 #print STDERR "dv1 >$pfx|$ref<\n";
 143     if (!$ref) {
 144         printf DEBUG "%s%s= %s\n", $pfx,$expr, evr($v);
 145         return;
 146     } elsif ($ref eq 'SCALAR') {
 147         dv1($pfx, ($expr =~ m/^\$/ ? "\$$expr" : '${'.$expr.'}'), $$v);
 148         return;
 149     }
 150     $expr.='->' unless $expr =~ m/\]$|\}$/;
 151     return if dv1_kind($pfx,$expr,$ref,'ARRAY','[%s]',
 152                        sub { ($[ .. $#$v) },
 153                        sub { $v->[$_[0]] });
 154     return if dv1_kind($pfx,$expr,$ref,'HASH','{%s}',
 155                        sub { sort keys %$v },
 156                        sub { $v->{$_[0]} });
 157     printf DEBUG "%s%s is %s\n", $pfx, $expr, $ref;
 158 }
 159
 160 sub dv {
 161     my ($pfx,@l) = @_;
 162     my ($expr,$v,$ref);
 163     while (@l) {
 164         ($expr,$v,@l)=@l;
 165         dv1($pfx,$expr,$v);
 166     }
 167 }
 168
 169 sub loc_lin_comb ($$$) {
 170     my ($a,$b,$p) = @_;
 171     my ($q,$r) = 1.0-$p;
 172     map { $r->{$_} = $q * $a->{$_} + $p * $b->{$_} } qw(X Y A);
 173 #    dv("loc_lin_comb ",'$a',$a,'$b',$b,'$p',$p,'$r',$r);
 174     return $r;
 175 }
 176
 177 $psu_ulen= 4.5;
 178 $psu_edgelw= 0.5;
 179 $psu_ticklw= 0.1;
 180 $psu_ticksperu= 3;
 181 $psu_ticklen= 3.0;
 182 $psu_allwidth= 37.0/2;
 183 $psu_gauge= 9;
 184 $psu_sleeperlen= 17;
 185 $psu_sleeperlw= 15;
 186 $psu_raillw= 1.0;
 187
 188 sub o ($) {
 189     # fixme optional marking
 190     print "$_[0]" or die $!;
 191 }
 192
 193 sub o_path_begin () {
 194     o("      newpath\n");
 195     $o_path_verb= 'moveto';
 196 }
 197 sub o_path_point ($) {
 198     my ($pt)=@_;
 199     o("        $pt $o_path_verb\n");
 200     $o_path_verb= 'lineto';
 201 }
 202 sub o_path_stroke ($) {
 203     my ($width)=@_;
 204     o("        $width setlinewidth stroke\n");
 205 }
 206
 207 sub o_line ($$$) {
 208     my ($a,$b,$width)=@_;
 209     o_path_begin();
 210     o_path_point($a);
 211     o_path_point($b);
 212     o_path_stroke($width);
 213 }
 214
 215 sub psu_coords ($$$) {
 216     my ($ends,$inunit,$across)=@_;
 217     # $ends->[0]{X} etc.; $inunit 0 to 1 (but go to 1.5);
 218     # $across in mm, +ve to right.
 219     my (%ea_zo);
 220     $ea_zo{X}=$ea_zo{Y}=0;
 221     foreach $zo (qw(0 1)) {
 222         $prop= $zo ? $inunit : (1.0 - $inunit);
 223         $ea_zo{X} += $prop * ($ends->[$zo]{X} - $across * sin($ends->[0]{A}));
 224         $ea_zo{Y} += $prop * ($ends->[$zo]{Y} + $across * cos($ends->[0]{A}));
 225     }
 226 #    dv("psu_coords ", '$ends',$ends, '$inunit',$inunit, '$across',$across,
 227 #       '\\%ea_zo', \%ea_zo);
 228     return $ea_zo{X}." ".$ea_zo{Y};
 229 }
 230
 231 sub parametric_segment ($$$$$) {
 232     my ($endstatuses,$p0,$p1,$lenperp,$calcfn) = @_;
 233     # makes $p (global) go from $p0 to $p1  ($p1>$p0)
 234     # $ends is II, SI, IS, SS (I=actual lineobj end, S=in mid of lineobj)
 235     # $lenperp is the length of one unit p, ie the curve
 236     # must have a uniform `density' in parameter space
 237     # $calcfn is invoked with $p set and should return a loc
 238     # (ie, ref to X =>, Y =>, A =>).
 239     my ($pa,$pb,@ends,$side,$ppu,$e,$v,$tick);
 240     $ppu= $psu_ulen/$lenperp;
 241     my ($railctr)=($psu_gauge + $psu_raillw)*0.5;
 242     my ($tickend)=($psu_allwidth - $psu_ticklen);
 243     my ($tickpitch)=($psu_ulen / $psu_ticksperu);
 244     my ($sleeperctr)=($psu_ulen*0.5);
 245     my ($sleeperend)=($psu_sleeperlen*0.5);
 246 print DEBUG "ps $p0 $p1 $lenperp ($ppu)\n";
 247     for ($pa= $p0; $pa<$p1; $pa=$pb) {
 248         $pb= $pa + $ppu;
 249         $p= $pa; $ends[0]= @ends ? $ends[1] : &$calcfn;
 250         $p= $pb; $ends[1]= &$calcfn;
 251 #print DEBUG "pa $pa $ends[0]{X} $ends[0]{Y} $ends[0]{A}\n";
 252 #print DEBUG "pb $pb $ends[1]{X} $ends[1]{Y} $ends[1]{A}\n";
 253         $e= $pb<=$p1 ? 1.0 : ($p1-$pa)/$ppu;
 254         o("    gsave\n");
 255         o_path_begin();
 256         o_path_point(psu_coords(\@ends,0,-$psu_allwidth));
 257         o_path_point(psu_coords(\@ends,0,$psu_allwidth));
 258         o_path_point(psu_coords(\@ends,$e,$psu_allwidth));
 259         o_path_point(psu_coords(\@ends,$e,-$psu_allwidth));
 260         o("        closepath clip\n");
 261         foreach $side qw(-1 1) {
 262             o_line(psu_coords(\@ends,0,$side*$psu_allwidth),
 263                    psu_coords(\@ends,1.5,$side*$psu_allwidth),
 264                    $psu_edgelw);
 265             o_line(psu_coords(\@ends,0,$side*$railctr),
 266                    psu_coords(\@ends,1.5,$side*$railctr),
 267                    $psu_raillw);
 268             for ($tick=0; $tick<1.5; $tick+=$tickpitch/$psu_ulen) {
 269                 o_line(psu_coords(\@ends,$tick,$side*$psu_allwidth),
 270                        psu_coords(\@ends,$tick,$side*$tickend),
 271                        $psu_ticklw);
 272             }
 273         }
 274         o_line(psu_coords(\@ends,$sleeperctr,-$sleeperend),
 275                psu_coords(\@ends,$sleeperctr,+$sleeperend),
 276                $psu_sleeperlw);
 277         o("      grestore\n");
 278     }
 279 }
 280
 281 sub cmd_extend {
 282     my ($from,$to,$radius,$ctr,$beta,$ang,$how,$signum);
 283     $from= can(\&cva_idex);
 284     $to= can(\&cva_idnew);
 285     printf DEBUG "from $from->{X} $from->{Y} $from->{A}\n";
 286     die "no ang" unless defined $from->{A};
 287     $how= can(cvam_enum(qw(len upto ang uptoang parallel)));
 288     if ($how eq 'len') { $len= can(\&cva_len); }
 289     elsif ($how =~ m/ang$/) { $ang= can(\&cva_ang); }
 290     elsif ($how eq 'parallel' || $how eq 'upto') { $upto= can(\&cva_idex); }
 291     $radius= cano(\&cva_len, 'Inf'); # +ve is right hand bend
 292     if ($radius eq 'Inf') {
 293         print DEBUG "extend inf $len\n";
 294         if ($how eq 'ang') { die "len of straight spec by angle"; }
 295         if ($how eq 'upto') {
 296             $len= ($upto->{X} - $from->{X}) * cos($from->{A})
 297                 + ($upto->{Y} - $from->{Y}) * sin($from->{A});
 298         }
 299         printf DEBUG "len $len\n";
 300         $to->{X}= $from->{X} + $len * cos($from->{A});
 301         $to->{Y}= $from->{Y} + $len * sin($from->{A});
 302         $to->{A}= $from->{A};
 303         parametric_segment(II, 0.0, 1.0, $len, sub {
 304             loc_lin_comb($from, $to, $p);
 305         });
 306     } else {
 307         print DEBUG "radius >$radius<\n";
 308         $signum= $radius / abs($radius);
 309         $ctr->{X}= $from->{X} + $radius * sin($from->{A});
 310         $ctr->{Y}= $from->{Y} - $radius * cos($from->{A});
 311         if ($how eq 'upto') {
 312             $beta= atan2(-$signum * ($upto->{X} - $ctr->{X}),
 313                          $signum * ($upto->{Y} - $ctr->{Y}));
 314             $beta_interval= 1.0;
 315         } elsif ($how eq 'parallel') {
 316             $beta= $upto->{A};
 317             $beta_interval= 1.0;
 318         } elsif ($how eq 'uptoang') {
 319             $beta= $ang;
 320             $beta_interval= 2.0;
 321         } elsif ($how eq 'len') {
 322             $beta= $from->{A} - $signum * $len / abs($radius);
 323             $beta_interval= 2.0;
 324         } else {
 325             $beta= $from->{A} - $signum * $ang;
 326             $beta_interval= 2.0;
 327         }
 328     printf DEBUG "ctr->{Y}=$ctr->{Y} radius=$radius beta=$beta\n";
 329         $beta += $signum * 4.0 * $pi;
 330         for (;;) {
 331             $delta= $beta - $from->{A};
 332             last if $signum * $delta <= 0;
 333             $beta -= $signum * $beta_interval * $pi;
 334         }
 335     printf DEBUG "ctr->{Y}=$ctr->{Y} radius=$radius beta=$beta\n";
 336         $to->{A}= $beta;
 337         $to->{X}= $ctr->{X} - $radius * sin($beta);
 338         $to->{Y}= $ctr->{Y} + $radius * cos($beta);
 339         parametric_segment(II, 0.0, 1.0, abs($radius*$delta), sub {
 340             my ($beta) = $from->{A} + $delta * $p;
 341             return { X => $ctr->{X} - $radius * sin($beta),
 342                      Y => $ctr->{Y} + $radius * cos($beta),
 343                      A => $beta }
 344         });
 345     }
 346     printf DEBUG "to $to->{X} $to->{Y} $to->{A}\n";
 347 }
 348
 349 sub cmd__do {
 350     $cmd= can(\&cva_cmd);
 351     &{ "cmd_$cmd" };
 352 }
 353
 354 $ptscale= 72/25.4 / 5.0;
 355
 356 o("%!\n".
 357   "  $ptscale $ptscale scale\n");
 358
 359 while (<>) {
 360     next if m/^\s*\#/;
 361     chomp; s/^\s+//; s/\s+$//;
 362     @al= split /\s+/, $_;
 363     next unless @al;
 364     print DEBUG "=== @al\n";
 365     $mark= 0;
 366     cmd__do();
 367 }
 368 dv('','\\%loc',\%loc);
 369 o("  showpage\n");