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