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 [ $1,$2 ];
 174 }
 175
 176 sub so_boob ($$) {
 177     my ($k,$bo) = @_;
 178     return sprintf "%5d /* %d.%-2d*/", $bo->[0] * 1000 + $bo->[1],
 179         $bo->[0], $bo->[1];
 180 }
 181
 182 sub so_oboob ($$) {
 183     my ($k,$obj) = @_;
 184     return so_boob($k,$obj->{BoOb});
 185 }
 186
 187 sub mainread () {
 188     $mistakes= 0;
 189     while (<>) {
 190         next if m/^\#/;
 191         chomp;
 192         s/\s+$//;
 193         next unless m/\S/;
 194         last if m/^end$/;
 195         if (m/^(invertible|vanilla|points|fixed|endwiring)$/) {
 196             $mode= $1;
 197             $invertible= ($mode eq 'invertible');
 198             $mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
 199             &{"begin_$mode"};
 200         } else {
 201             $currentline= $_;
 202             &{"line_$mode"};
 203         }
 204     }
 205 }
 206
 207 sub nummap ($) {
 208     my ($p) = @_;
 209     $p =~ s/\d{1,6}/ sprintf "%06d%d",$&,$& /ge;
 210     return $p;
 211 }
 212
 213 sub writeout () {
 214     my (@segs,$segn,$seg,$segr,$pt,$ptv, $delim);
 215     my ($comb,$pi,$feat,$featr,$end,$boob);
 216     my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
 217     o("/* autogenerated - do not edit */\n\n");
 218     @segs=();
 219     for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
 220         $segs{$seg}{Num}= @segs;
 221         push @segs, $seg;
 222     }
 223     o(sprintf
 224       "#define NUM_TRAINS 1000000\n".
 225       "#define NUM_SEGMENTS %s\n\n".
 226       "#include \"layout-data.h\"\n\n",
 227       scalar @segs);
 228     foreach $seg (@segs) {
 229         $segr= $segs{$seg};
 230
 231         o("static const SegPosCombInfo spci_${seg}[]= {");
 232         $delim='';
 233         for ($comb=0; $comb < $segr->{Posns}; $comb++) {
 234             $pi='';
 235             foreach $feat (keys %{ $segr->{Feats} }) {
 236                 $featr= $segr->{Feats}{$feat};
 237                 next if exists $featr->{Fixed};
 238                 $pi.= sprintf("%s%d", $feat,
 239                               ($comb / $featr->{Weight}) % $featr->{Posns});
 240             }
 241             o("$delim\n");
 242             o(sprintf "  { %-8s %4d",
 243               '"'.$seg.(length $pi ? '/' : '').$pi.'",',
 244               $segr->{Dist}[$comb]);
 245             for ($end=0; $end<2; $end++) {
 246                 o(", { ");
 247                 $otherend= $segr->{Ends}[$comb][$end];
 248                 defined $otherend or die "$seg $comb $end ?";
 249                 ($node,$side) = @$otherend;
 250                 $nodeotherside= $nodes{$node}[1-$side];
 251                 if (defined $nodeotherside) {
 252                     $otherseg= $nodeotherside->{Seg};
 253                     $otherbackrelus= $nodeotherside->{End} ^ $end ^ 1;
 254                     o(sprintf "/*%5s.%d %-5s*/ %d,%3d",
 255                       $node,$side,
 256                       ($otherbackrelus?'-':' ').$otherseg,
 257                       $otherbackrelus,
 258                       $segs{$otherseg}{Num});
 259                 } else {
 260                     o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
 261                       $node,$side);
 262                 }
 263                 o(" }");
 264             }
 265             o(sprintf " }");
 266             $delim= ',';
 267         }
 268         o("\n};\n");
 269
 270         next unless $segr->{FeatCount};
 271
 272         for $pt (keys %{ $segr->{Feats} }) {
 273             $ptv= $segr->{Feats}{$pt};
 274             next if exists $ptv->{Fixed};
 275             o("static const BoardObject mfbo_${seg}_${pt}[]= {");
 276             $delim=' ';
 277             foreach $boob (@{ $ptv->{BoOb} }) {
 278                 o($delim);
 279                 o(so_boob('pt',$boob));
 280                 $delim= ', ';
 281             }
 282             o(" };\n");
 283         }
 284
 285         o("static const MovFeatInfo mfi_${seg}[]= {");
 286         $delim='';
 287         for $pt (keys %{ $segr->{Feats} }) {
 288             $ptv= $segr->{Feats}{$pt};
 289             next if exists $ptv->{Fixed};
 290             o("$delim\n");
 291             o("  { \"$seg/$pt\", mfk_".lc($ptv->{Kind}).",".
 292               " $ptv->{Posns}, $ptv->{Weight}, mfbo_${seg}_$pt }");
 293             $delim=',';
 294         }
 295         o("\n};\n");
 296     }
 297     o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
 298     o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
 299     $delim= '';
 300     foreach $seg (@segs) {
 301         $segr= $segs{$seg};
 302         o("$delim\n");
 303         o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-10s %-6s }",
 304           "\"$seg\",", $segr->{Inv},
 305           $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
 306           $segr->{Posns}, "spci_$seg,",
 307           so_oboob('sense',$segr), so_oboob('reverse',$segr));
 308         $delim= ',';
 309     }
 310     o("\n};\n");
 311 }
 312
 313 mainread();
 314 writeout();