layout/data2safety

   1 #!/usr/bin/perl -w
   2
   3 use strict qw(vars);
   4
   5 our ($mistakes, $currentline);
   6
   7 our (%segs);
   8 # $segs{$seg}{Inv}
   9 # $segs{$seg}{BoOb}
  10 # $segs{$seg}{Posns}
  11 # $segs{$seg}{FeatCount}              does not include Fixed
  12 # $segs{$seg}{Feats}{$pt}{Kind}       Point or Fixed
  13 # $segs{$seg}{Feats}{$pt}{Weight}     ) for Point only
  14 # $segs{$seg}{Feats}{$pt}{Posns}      ) for Point only
  15 # $segs{$seg}{Feats}{$pt}{BoOb}       ) for Point only
  16 # $segs{$seg}{Feats}{$pt}{Fixed}      position, for Fixed only
  17
  18 # $segs{$seg}{Num}
  19 # $segs{$seg}{Ends}[$combpos][$end] = [ $node,$side ]
  20 # $segs{$seg}{Dist}[$combpos]
  21
  22 our (%nodes);
  23 # $nodes{$node}[$side]{Seg}
  24 # $nodes{$node}[$side]{End}
  25
  26 our ($mode,$invertible);
  27 $mode= 'barf';
  28
  29 sub line_barf () {
  30     return if $mistakes;
  31     mistake("first input line does not determine phase");
  32 }
  33
  34 sub syntaxerror () {
  35     our (%syntaxerror_once);
  36     return if exists $syntaxerror_once{$mode};
  37     $syntaxerror_once{$mode}= 1;
  38     mistake("syntax error");
  39     return undef;
  40 }
  41
  42 sub ditch ($) {
  43     my ($m) = @_;
  44     print STDERR "ditching $m\n";
  45 }
  46
  47 sub begin_points () { }
  48 sub line_points () {
  49     my ($seg,$pt,@boob,$bodef);
  50     m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
  51         return syntaxerror();
  52     ($seg,$pt,$boob[0],$bodef,$boob[1])=($1,$2,$3,$4,$5);
  53     $boob[1] =~ s/^\./$bodef./;
  54     mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
  55     mistake("duplicate wiring for $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
  56     $segs{$seg}{Feats}{$pt}= {
  57         Kind => Point,
  58         Weight => $segs{$seg}{Posns},
  59         Posns => 2,
  60         BoOb => [ map { pa_boob($_) } @boob ]
  61         };
  62     $segs{$seg}{Posns} *= 2;
  63     $segs{$seg}{FeatCount}++;
  64 }
  65
  66 sub begin_fixed () { }
  67 sub line_fixed () {
  68     my ($seg,$pt,$pos);
  69     m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
  70     ($seg,$pt,$pos)=($1,$2,$3);
  71     mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
  72     mistake("duplicate fixed $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
  73     $segs{$seg}{Feats}{$pt}= {
  74         Kind => Fixed,
  75         Fixed => $pos
  76         };
  77 }
  78
  79 sub begin_segment () { }
  80 sub line_segment () {
  81     my ($seg,$boob);
  82     m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
  83     ($seg,$boob)=($1,$2);
  84     mistake("duplicate topology for $seg") if exists $segs{$seg};
  85     $segs{$seg}= {
  86         BoOb => pa_boob($boob),
  87         Inv => $invertible,
  88         Posns => 1,
  89         Feats => { },
  90         FeatCount => 0
  91     };
  92 }
  93
  94 sub begin_endwiring () {
  95 }
  96
  97 sub mistake ($) {
  98     my ($m) = @_;
  99     print STDERR "mistake: $m\n in $mode, \`$currentline'\n";
 100     $mistakes++;
 101 }
 102
 103 sub line_endwiring () {
 104     my (@ns,$seg,$subspec,$dist);
 105     my ($segr,@subsegil,$feat,$pos,$featr,$combpos,%featposwant);
 106     my ($end,$node,$side,$nsr,$endposr);
 107     m,^\s*segment\s+(\w+\.\d+)\s+(\w+\.\d+)\s+(\w+)(?:/((?:[A-Za-z]+\d+)+)\*\d+)?\s+([0-9.]+)$, or return syntaxerror();
 108     ($ns[0],$ns[1],$seg,$subspec,$dist)=($1,$2,$3,$4,$5);
 109     if (!exists $segs{$seg}) {
 110         ditch("unwired $seg$subspec");
 111         return;
 112     }
 113     $segr= $segs{$seg};
 114     @subsegil= defined $subspec ? $subspec =~ m/([A-Za-z]+)(\d+)/g : ();
 115     while (@subsegil) {
 116         ($feat,$pos,@subsegil) = @subsegil;
 117         if (!exists $segr->{Feats}{$feat}) {
 118             mistake("no wiring for $seg/$feat");
 119             next;
 120         }
 121         $featr= $segr->{Feats}{$feat};
 122         if (exists $featr->{Fixed}) {
 123             if ($pos != $featr->{Fixed}) {
 124                 ditch("fixed-elsewise $seg$subspec");
 125                 return;
 126             }
 127         } else {
 128             mistake("position $seg/$feat$pos exceeds wiring")
 129                 unless $pos < $featr->{Posns};
 130             $featposwant{$feat}= $pos;
 131         }
 132     }
 133     $combpos= 0;
 134     for $feat (keys %{ $segr->{Feats} }) {
 135         $featr= $segr->{Feats}{$feat};
 136         next if exists $featr->{Fixed};
 137         mistake("wiring $seg/$feat not covered by $seg/$subspec")
 138             if !exists $featposwant{$feat};
 139         $combpos += $featposwant{$feat} * $featr->{Weight};
 140     }
 141     mistake("duplicate topology for $seg/$subspec")
 142         if defined $segs{$seg}{Dist}[$combpos];
 143     $segs{$seg}{Dist}[$combpos]= $dist;
 144     $endposr= $segr->{Ends}[$combpos];
 145     die "$seg $combpos @$endposr ?" if defined $endposr && @$endposr;
 146     for ($end=0; $end<2; $end++) {
 147         $ns[$end] =~ m/^([a-z]\w+)\.([01])$/;
 148         ($node,$side)=($1,$2);
 149         $nsr= $nodes{$node}[$side];
 150         if (!exists $nsr->{Seg}) {
 151             $nodes{$node}[$side]= { Seg => $seg, End => $end };
 152         } else {
 153             $seg eq $nsr->{Seg} or
 154                 mistake("topology for $node.$side both $seg and $nsr->{Seg}");
 155             $end == $nsr->{End} or
 156                 mistake("topology for $node.$side $seg both ends ($end".
 157                         " and also $nsr->{End})");
 158         }
 159         $segr->{Ends}[$combpos][$end]= [ $node, $side ];
 160     }
 161 }
 162
 163 sub o ($) {
 164     print STDOUT $_[0] or die $!;
 165 }
 166
 167 sub pa_boob ($) {
 168     my ($boob) = @_;
 169     if ($boob !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
 170         mistake("invalid board object $boob");
 171         return [ 0,0 ];
 172     }
 173     return sprintf "%d,%2d", $1,$2;
 174 }
 175
 176 sub so_oboob ($) {
 177     my ($obj) = @_;
 178     return $obj->{BoOb};
 179 }
 180
 181 sub mainread () {
 182     $mistakes= 0;
 183     while (<>) {
 184         next if m/^\#/;
 185         chomp;
 186         s/\s+$//;
 187         next unless m/\S/;
 188         last if m/^end$/;
 189         if (m/^(invertible|vanilla|points|fixed|endwiring)$/) {
 190             $mode= $1;
 191             $invertible= ($mode eq 'invertible');
 192             $mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
 193             &{"begin_$mode"};
 194         } else {
 195             $currentline= $_;
 196             &{"line_$mode"};
 197         }
 198     }
 199 }
 200
 201 sub nummap ($) {
 202     my ($p) = @_;
 203     $p =~ s/\d{1,6}/ sprintf "%06d%d",$&,$& /ge;
 204     return $p;
 205 }
 206
 207 sub writeout () {
 208     my (@segs,$segn,$seg,$segr,$pt,$ptv, $delim);
 209     my ($comb,$pi,$feat,$featr,$end);
 210     my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
 211     o("/* autogenerated - do not edit */\n\n");
 212     @segs=();
 213     for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
 214         $segs{$seg}{Num}= @segs;
 215         push @segs, $seg;
 216     }
 217     o(sprintf
 218       "#define NUM_TRAINS 1000000\n".
 219       "#define NUM_SEGMENTS %s\n\n".
 220       "#include \"layout-data.h\"\n\n",
 221       scalar @segs);
 222     foreach $seg (@segs) {
 223         $segr= $segs{$seg};
 224
 225         o("static const SegPosCombInfo spci_${seg}[]= {");
 226         $delim='';
 227         for ($comb=0; $comb < $segr->{Posns}; $comb++) {
 228             $pi='';
 229             foreach $feat (keys %{ $segr->{Feats} }) {
 230                 $featr= $segr->{Feats}{$feat};
 231                 next if exists $featr->{Fixed};
 232                 $pi.= sprintf("%s%d", $feat,
 233                               ($comb / $featr->{Weight}) % $featr->{Posns});
 234             }
 235             o("$delim\n");
 236             o(sprintf "  { %-8s %4d",
 237               '"'.$seg.(length $pi ? '/' : '').$pi.'",',
 238               $segr->{Dist}[$comb]);
 239             for ($end=0; $end<2; $end++) {
 240                 o(", { ");
 241                 $otherend= $segr->{Ends}[$comb][$end];
 242                 defined $otherend or die "$seg $comb $end ?";
 243                 ($node,$side) = @$otherend;
 244                 $nodeotherside= $nodes{$node}[1-$side];
 245                 if (defined $nodeotherside) {
 246                     $otherseg= $nodeotherside->{Seg};
 247                     $otherbackrelus= $nodeotherside->{End} ^ $end ^ 1;
 248                     o(sprintf "/*%5s.%d %-5s*/ %d,%3d",
 249                       $node,$side,
 250                       ($otherbackrelus?'-':' ').$otherseg,
 251                       $otherbackrelus,
 252                       $segs{$otherseg}{Num});
 253                 } else {
 254                     o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
 255                       $node,$side);
 256                 }
 257                 o(" }");
 258             }
 259             o(sprintf " }");
 260             $delim= ',';
 261         }
 262         o("\n};\n");
 263
 264         next unless $segr->{FeatCount};
 265
 266         o("static const MovFeatInfo mfi_${seg}[]= {");
 267         $delim='';
 268         for $pt (keys %{ $segr->{Feats} }) {
 269             $ptv= $segr->{Feats}{$pt};
 270             next if exists $ptv->{Fixed};
 271             o("$delim\n");
 272             o("  { \"$seg/$pt\", $ptv->{Posns}, $ptv->{Weight} }");
 273             $delim=',';
 274         }
 275         o("\n};\n");
 276     }
 277     o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
 278     o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
 279     $delim= '';
 280     foreach $seg (@segs) {
 281         $segr= $segs{$seg};
 282         o("$delim\n");
 283         o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-10s %-6s }",
 284           "\"$seg\",", $segr->{Inv},
 285           $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
 286           $segr->{Posns}, "spci_$seg,",
 287           so_oboob($segr));
 288         $delim= ',';
 289     }
 290     o("\n};\n");
 291 }
 292
 293 mainread();
 294 writeout();