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       "#include \"safety.h\"\n\n");
 213     @segs=();
 214     for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
 215         $segs{$seg}{Num}= @segs;
 216         push @segs, $seg;
 217     }
 218     foreach $seg (@segs) {
 219         $segr= $segs{$seg};
 220
 221         o("static const SegPosCombInfo spci_${seg}[]= {");
 222         $delim='';
 223         for ($comb=0; $comb < $segr->{Posns}; $comb++) {
 224             $pi='';
 225             foreach $feat (keys %{ $segr->{Feats} }) {
 226                 $featr= $segr->{Feats}{$feat};
 227                 next if exists $featr->{Fixed};
 228                 $pi.= sprintf("%s%d", $feat,
 229                               ($comb / $featr->{Weight}) % $featr->{Posns});
 230             }
 231             o("$delim\n");
 232             o(sprintf "  %-10s {", length $pi ? "/*$pi*/" : '');
 233             for ($end=0; $end<2; $end++) {
 234                 o(',') if $end;
 235                 o(" { ");
 236                 $otherend= $segr->{Ends}[$comb][$end];
 237                 defined $otherend or die "$seg $comb $end ?";
 238                 ($node,$side) = @$otherend;
 239                 $nodeotherside= $nodes{$node}[1-$side];
 240                 if (defined $nodeotherside) {
 241                     $otherseg= $nodeotherside->{Seg};
 242                     $otherbackrelus= $nodeotherside->{End} ^ $end ^ 1;
 243                     o(sprintf "/*%5s.%d %-6s*/ %d,%3d",
 244                       $node,$side,
 245                       ($otherbackrelus?'-':' ').$otherseg,
 246                       $otherbackrelus,
 247                       $segs{$otherseg}{Num});
 248                 } else {
 249                     o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
 250                       $node,$side);
 251                 }
 252                 o(" }");
 253             }
 254             o(sprintf " }");
 255             $delim= ',';
 256         }
 257         o("\n};\n");
 258
 259         next unless $segr->{FeatCount};
 260
 261         o("static const MovFeatInfo mfi_${seg}[]= {");
 262         $delim='';
 263         for $pt (keys %{ $segr->{Feats} }) {
 264             $ptv= $segr->{Feats}{$pt};
 265             next if exists $ptv->{Fixed};
 266             o("$delim\n");
 267             o("  { \"$seg/$pt\", $ptv->{Posns}, $ptv->{Weight} }");
 268             $delim=',';
 269         }
 270         o("\n};\n");
 271     }
 272     o("static const SegmentInfo info_segments[".scalar(@segs)."]= {");
 273     $delim= '';
 274     foreach $seg (@segs) {
 275         $segr= $segs{$seg};
 276         o("$delim\n");
 277         o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-10s %-6s }",
 278           "\"$seg\",", $segr->{Inv},
 279           $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
 280           $segr->{Posns}, "spci_$seg,",
 281           so_oboob($segr));
 282         $delim= ',';
 283     }
 284     o("\n};\n");
 285 }
 286
 287 mainread();
 288 writeout();