layout/data2safety

   1 #!/usr/bin/perl -w
   2
   3 use strict qw(vars);
   4
   5 our ($basename);
   6 $basename= @ARGV ? $ARGV[0] : 'safety';
   7 die if $basename =~ m/^\-/;
   8 $basename =~ s/\.wiring$//;
   9
  10 our ($mistakes, $currentline);
  11
  12 our (%segs);
  13 # ->{BoOb}{Kind}  'pt' 'sense' 'reverse' 'waggle'
  14 # ->{BoOb}{Board}
  15 # ->{BoOb}{Obj}
  16 # ->{BoOb}{Indiv}   for `indiv' board objects like wagglers
  17 # $segs{$seg}{InvBoOb}
  18 # $segs{$seg}{BoOb}
  19 # $segs{$seg}{Posns}
  20 # $segs{$seg}{FeatCount}                does not include Fixed
  21 # $segs{$seg}{FeatCountFixed}
  22 # $segs{$seg}{Feats}{$feat}{Kind}       Point, Fixed, or Relay
  23 # $segs{$seg}{Feats}{$feat}{Weight}     ) for Point or Relay only
  24 # $segs{$seg}{Feats}{$feat}{Posns}      ) for Point or Relay only
  25 # $segs{$seg}{Feats}{$feat}{BoObs}[]    ) for Point or Relay only
  26 # $segs{$seg}{Feats}{$feat}{Fixed}      position, for Fixed only
  27 # $segs{$seg}{FeatMap}[]{Abstract}      as from ours.m4
  28 # $segs{$seg}{FeatMap}[]{Concrete}      as in ours.wiring, for safety:movpos.c
  29 # $segs{$seg}{FeatMap}[]{UsedAbstract}
  30 # $segs{$seg}{FeatMap}[]{UsedConcrete}
  31 # $segs{$seg}{Inter}{Seg}               ) calculated
  32 # $segs{$seg}{Inter}{Map}               )  in writeout
  33
  34 # $segs{$seg}{Num}
  35 # $segs{$seg}{Ends}[$combpos][$end] = [ $node,$side ]
  36 # $segs{$seg}{Dist}[$combpos]
  37
  38 our (@interfs);
  39 # $interfs[]{Invert} = $invert
  40 # $interfs[]{Segs}[] = "$seg/$posre"   "/.*" added during parsing if necc.
  41
  42 our (%nodes);
  43 # $nodes{$node}[$side]{Seg}
  44 # $nodes{$node}[$side]{End}
  45
  46 our ($maxptixln2) = 5;
  47 our ($maxwaggleixln2) = 4;
  48
  49 our ($nextboardnum,@boardtype,@sensesin,$maxreverseobjnum);
  50 our (@reversersboardnum,@sensesbase,@objkinds,%pin_used);
  51 # $boardtype[$boardnum]
  52 # $sensesin[$page]
  53 # $maxreverseobjnum
  54 # $reversersboardnum[$boardnum]  # undef => none; -1 => not yet determined
  55 # $sensesbase[$boardnum]= ($page << 7) | $baselsbyte
  56 # $pin_used{$objkind}[$objnum] = [ $boardnum, $pin_info, $objonboard ]
  57 $nextboardnum= 0;
  58 $sensesin[0]= 0;
  59 @objkinds= qw(pt sense reverse waggle);
  60
  61 our (%kind_count,%pin_info,%pin_info_indiv); # from BOARD.pin-info
  62
  63 our ($mode,$invertible);
  64 $mode= 'barf';
  65
  66 our (%sensepermute);
  67 # $sensepermute{$boardtype}[$objonboard]= $offset
  68
  69 sub sensepermute_bitmap ($$$) {
  70     my ($kind,$base,$mapstring) = @_;
  71     my ($objnum,$bitnum);
  72     my (@map)= split /\s+/, $mapstring;
  73     @map==8 or die;
  74     $bitnum= $base;
  75     while (@map) {
  76         $objnum= pop @map;
  77         next if $objnum =~ m/[a-z]/i;
  78         $objnum =~ m/^\d\d$/ or die "$kind $objnum ($bitnum) ?";
  79         $objnum =~ s/^0*\B//;
  80         die "$kind $objnum ($bitnum from $base)" if
  81             defined $sensepermute{$kind}[$objnum];
  82         $sensepermute{$kind}[$objnum]= $bitnum;
  83 #print STDERR "SPM $kind $objnum $bitnum\n";
  84         $bitnum++;
  85     }
  86 }
  87 # see detect.asm:
  88 sensepermute_bitmap('reversers',  0, 'MM zz 01 02  03 00 04 05');
  89 sensepermute_bitmap('detectors',  0, 'MM 05 B2 B1  10 13 16 08');
  90 sensepermute_bitmap('detectors',  5, '19 09 12 15  18 04 20 17');
  91 sensepermute_bitmap('detectors', 13, '06 01 07 02  11 14 03 00');
  92
  93 sub line_barf () {
  94     return if $mistakes;
  95     mistake("first input line does not determine phase");
  96 }
  97
  98 sub syntaxerror () {
  99     our (%syntaxerror_once);
 100     return if exists $syntaxerror_once{$mode};
 101     $syntaxerror_once{$mode}= 1;
 102     mistake("syntax error");
 103     return undef;
 104 }
 105
 106 sub ditch ($) {
 107     my ($m) = @_;
 108     print STDERR "info: ditching $m\n";
 109 }
 110
 111 sub seg_wiring ($$$) {
 112     my ($seg,$feat,$hash) = @_;
 113     if (!exists $segs{$seg}) {
 114         foreach my $bo (@{ $hash->{BoObs} }) {
 115             so_boob(1,$bo);
 116         }
 117         ditch("unwired segment for wired point $seg/$feat");
 118         return;
 119     }
 120     mistake("duplicate wiring for $seg/$feat")
 121         if exists $segs{$seg}{Feats}{$feat};
 122     if (exists $hash->{Posns}) {
 123         $hash->{Weight}= $segs{$seg}{Posns};
 124         $segs{$seg}{Posns} *= 2;
 125         $segs{$seg}{FeatCount}++;
 126     }
 127     $segs{$seg}{Feats}{$feat}= $hash;
 128 }
 129
 130 sub begin_points () { }
 131 sub line_points () {
 132     my ($seg,$pt,@boobstr,$bodef,@boobs);
 133     m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
 134         return syntaxerror();
 135     ($seg,$pt,$boobstr[0],$bodef,$boobstr[1])=($1,$2,$3,$4,$5);
 136     $boobstr[1] =~ s/^\./$bodef./;
 137     @boobs= map { pa_boob('pt',$_) } @boobstr;
 138     seg_wiring($seg,$pt, {
 139         Kind => Point,
 140         Posns => 2,
 141         BoObs => [ @boobs ],
 142     });
 143 }
 144
 145 sub begin_relays () { }
 146 sub line_relays () {
 147     my ($seg,$rly,$waggle);
 148     m,^\s+(\w+)/([A-Za-z]+)\s+([1-9]\d*|0)\.(\w+)$, or return syntaxerror();
 149     ($seg,$rly)= ($1,$2);
 150     $waggle= { Kind => 'waggle', Board => $3, Indiv => $4 };
 151     seg_wiring($seg,$rly, {
 152         Kind => Relay,
 153         Posns => 2,
 154         BoObs => [ $waggle ],
 155     });
 156 }
 157
 158 sub begin_fixed () { }
 159 sub line_fixed () {
 160     my ($seg,$feat,$pos);
 161     m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
 162     ($seg,$feat,$pos)=($1,$2,$3);
 163     seg_wiring($seg,$feat, {
 164         Kind => Fixed,
 165         Fixed => $pos,
 166     });
 167     $segs{$seg}{FeatCountFixed}++;
 168 }
 169
 170 sub begin_segment () { }
 171 sub line_segment () {
 172     my ($seg,$boobstr,$boob);
 173     m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
 174     ($seg,$boobstr)=($1,$2);
 175     mistake("duplicate topology for segment $seg") if exists $segs{$seg};
 176     $boob= pa_boob('sense', $boobstr);
 177     $segs{$seg}= {
 178         BoOb => $boob,
 179         InvBoOb => $invertible ? { Kind => 'reverse',
 180                                    Board => $boob->{Board},
 181                                    Obj => $boob->{Obj} } : undef,
 182         Posns => 1,
 183         Feats => { },
 184         FeatCount => 0,
 185         FeatCountFixed => 0
 186     };
 187     &{"line_segment_".($invertible?'invertible':'vanilla')}($boob);
 188 }
 189
 190 sub begin_endwiring () {
 191 }
 192
 193 sub begin_boards () {
 194 }
 195 sub line_boards () {
 196     my ($num,$type,$k);
 197     m/^\s+(\d+)\s+(\w+)$/ or return syntaxerror();
 198     ($num,$type)=($1,$2);
 199     mistake("board $num when expected $nextboardnum")
 200         if $num != $nextboardnum;
 201
 202     $nextboardnum++;
 203     $boardtype[$num]= $type;
 204     require "./$type.pin-info";
 205
 206     my ($sense_count, $page);
 207     $sense_count= $kind_count{$type}{'sense'};
 208     for ($page=0;
 209          $sensesin[$page] + $sense_count > 128;
 210          $page++) {
 211         mistake("too many senses for encoding scheme")
 212             if $page > 7;
 213         push @sensesin, 0
 214             if $page > $#sensesin;
 215     }
 216     $sensesbase[$num]= ($page << 7) | $sensesin[$page];
 217     $sensesin[$page] += $sense_count;
 218
 219     &{"line_boards_$type"}($num);
 220 }
 221
 222 sub line_boards_reversers { }
 223 sub line_boards_detectors { }
 224 sub line_segment_vanilla ($) { }
 225 sub line_segment_invertible ($) {
 226     my ($boob) = @_;
 227     $reversersboardnum[ $boob->{Board} ]= -1;
 228 }
 229
 230 sub begin_interferences () {
 231 }
 232 sub line_interferences () {
 233     s/^\s+// or return syntaxerror();
 234     my ($is) = [ split /\s+/, $_ ];
 235     my ($invert)= 0;
 236     if ($is->[0] eq '-') {
 237         shift @$is;
 238         $invert= 1;
 239     }
 240     map {
 241         $invert ^= 1 if s/^\-//;
 242         s,$,/.*, unless m,/,;
 243     } @$is;
 244     return syntaxerror() if grep { !m,^\w+/, } @$is;
 245     push @interfs, { Invert => $invert, Segs => $is };
 246 }
 247
 248 # We read the movfeatmap and write out most things in the output to
 249 # have the concrete (RHS) version; the exception is layout-data.c
 250 # SegPosCombInfo.pname.
 251 #
 252 # The FeatMap is a bidirectional mapping constructed from "movfeatposmap"
 253 # lines, a map between ([A-Za-z]+[0-9]+)* and ([A-Za-z]+[0-9]+)*.
 254 #
 255 # It has two effects:
 256 #     - in line_endwiring, used "forwards"
 257 #     - when writing out .pname, used "backwards"
 258 # in each case we match only whole feature positions by regexp tricks
 259 # we record whether a mapping entry was used, and complain if not
 260
 261 sub begin_movfeatposmap () { }
 262 sub line_movfeatposmap () {
 263     my ($segr,$abstr_namebase,$abstr_firstpos,$abstr_lastpos,$conc_posns) =
 264        m,^\s+(\w+)\s+([A-Za-z]+)(\d+)(?:\-(\d+))?((?:\s+(?:[A-Za-z]+\d+)*)+)$,;
 265     defined $segr or return syntaxerror();
 266
 267     $abstr_lastpos= $abstr_firstpos unless defined $abstr_lastpos;
 268     my $nabstr_posns= $abstr_lastpos - $abstr_firstpos + 1;
 269
 270     $conc_posns =~ s/^\s+//;
 271     my (@conc_posns) = split /\s+/, $conc_posns;
 272
 273     my $seg= $segs{$segr};
 274     if (!$seg) {
 275         ditch("movfeatposmap for unwired segment".
 276               " $segr/$abstr_namebase$abstr_firstpos".
 277               ($nabstr_posns>1 ? "-$abstr_lastpos" : ""));
 278         return;
 279     }
 280
 281     @conc_posns == $nabstr_posns
 282         or return mistake("number of concrete poscombs ".@conc_posns.
 283                           " differs from number of abstract poscombs".
 284                           " $nabstr_posns");
 285     for (my $i=0; $i<@conc_posns; $i++) {
 286         push @{ $seg->{FeatMap} }, {
 287             Abstract => $abstr_namebase.($abstr_firstpos+$i),
 288             Concrete => $conc_posns[$i],
 289             Used => 0,
 290         };
 291     }
 292 }
 293
 294 sub mistake ($) {
 295     my ($m) = @_;
 296     print STDERR "mistake: $m\n in $mode, \`$currentline'\n";
 297     $mistakes++;
 298 }
 299
 300 sub endmistake ($) {
 301     my ($m) = @_;
 302     print STDERR "mistake: $m\n";
 303     $mistakes++;
 304 }
 305
 306 sub movfeatposmap ($$$$$) {
 307     my ($subspecr, $segr, $entfrom, $entto, $call) = @_;
 308     my $featmap= $segr->{FeatMap};
 309     return unless $featmap;
 310
 311     foreach my $mapent (@$featmap) {
 312         next unless
 313             $$subspecr =~ s/
 314                 (?<! [A-Za-z] ) $mapent->{$entfrom} (?! \d )
 315                 /$mapent->{$entto}/x;
 316         $mapent->{"Used$entfrom"}++;
 317         $call->($mapent);
 318     }
 319 }
 320
 321 sub movfeatposmap_checks () {
 322     foreach my $seg (keys %segs) {
 323         my $segr= $segs{$seg};
 324         my $featmap= $segr->{FeatMap};
 325         next unless $featmap;
 326         foreach my $mapent (@$featmap) {
 327             foreach my $chk (qw(Abstract Concrete)) {
 328                 next if $mapent->{"Used$chk"};
 329                 endmistake("movfeatposmap entry $seg $mapent->{Abstract}".
 330                            " $mapent->{Concrete} unused for \L$chk lookup");
 331                 last;
 332             }
 333         }
 334     }
 335 }
 336
 337 sub line_endwiring () {
 338     my (@ns,$seg,$subspec,$dist);
 339     my ($segr,@subsegil,$feat,$pos,$featr,$combpos,%featposwant);
 340     my ($end,$node,$side,$nsr,$endposr);
 341     m,^\s*segment\s+(\w+\.\d+)\s+(\w+\.\d+)\s+(\w+)(?:/((?:[A-Za-z]+\d+)+)\*\d+)?\s+([0-9.]+)$, or return syntaxerror();
 342     ($ns[0],$ns[1],$seg,$subspec,$dist)=($1,$2,$3,$4,$5);
 343     if (!exists $segs{$seg}) {
 344         ditch("unwired $seg".(defined $subspec ? "/$subspec" : ""));
 345         return;
 346     }
 347     $segr= $segs{$seg};
 348     my $desc= $seg;
 349     if (defined $subspec) {
 350         $desc .= "/$subspec";
 351         movfeatposmap(\$subspec, $segr, Abstract, Concrete, sub {
 352             my ($mapent) = @_;
 353             $desc .= "[$mapent->{Concrete}]";
 354         });
 355     }
 356     @subsegil= defined $subspec ? $subspec =~ m/([A-Za-z]+)(\d+)/g : ();
 357     while (@subsegil) {
 358         ($feat,$pos,@subsegil) = @subsegil;
 359         if (!exists $segr->{Feats}{$feat}) {
 360             mistake("no wiring for $seg/$feat");
 361             next;
 362         }
 363         $featr= $segr->{Feats}{$feat};
 364         if (exists $featr->{Fixed}) {
 365             if ($pos != $featr->{Fixed}) {
 366                 ditch("fixed-elsewise $desc");
 367                 return;
 368             }
 369         } else {
 370             mistake("position $seg/$feat$pos exceeds wiring")
 371                 unless $pos < $featr->{Posns};
 372             $featposwant{$feat}= $pos;
 373         }
 374     }
 375     $combpos= 0;
 376     for $feat (keys %{ $segr->{Feats} }) {
 377         $featr= $segr->{Feats}{$feat};
 378         next if exists $featr->{Fixed};
 379         mistake("wiring $seg/$feat not covered by $desc"),next
 380             if !exists $featposwant{$feat};
 381         $combpos += $featposwant{$feat} * $featr->{Weight};
 382     }
 383     mistake("duplicate topology subseg for $desc")
 384         if defined $segs{$seg}{Dist}[$combpos];
 385     $segs{$seg}{Dist}[$combpos]= $dist;
 386     $endposr= $segr->{Ends}[$combpos];
 387     die "$seg $combpos ".(map { "@$_" } @$endposr)." ?"
 388         if defined $endposr && @$endposr;
 389     for ($end=0; $end<2; $end++) {
 390         $ns[$end] =~ m/^([a-z]\w+)\.([01])$/;
 391         ($node,$side)=($1,$2);
 392         $nsr= $nodes{$node}[$side];
 393         if (!exists $nsr->{Seg}) {
 394             $nodes{$node}[$side]= { Seg => $seg, End => $end };
 395         } else {
 396             $seg eq $nsr->{Seg} or
 397                 mistake("topology for $node.$side both $seg and $nsr->{Seg}");
 398             $end == $nsr->{End} or
 399                 mistake("topology for $node.$side $seg both ends ($end".
 400                         " and also $nsr->{End})");
 401         }
 402         $segr->{Ends}[$combpos][$end]= [ $node, $side ];
 403     }
 404 }
 405
 406 sub o ($) {
 407     print STDOUT $_[0] or die $!;
 408 }
 409
 410 sub pa_boob ($$) {
 411     my ($kind,$str) = @_;
 412     if ($str !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
 413         mistake("invalid board object $str");
 414         return { Kind => $kind, Board => 0, Obj => 0 };
 415     }
 416     return { Kind => $kind, Board => $1, Obj => $2 };
 417 }
 418
 419 # boob2objnum_KIND($boob,$boardnum,$objnum,$boardtype,$mkused ...)
 420 #  -> global object number
 421
 422 sub boob2objnum_waggle {
 423     my ($boob,$boardnum,$obj) = @_;
 424     mistake("waggle encoding out of range") if
 425         $boardnum >= (1 << (9 - $maxwaggleixln2));
 426     die if $obj >= (1 << $maxwaggleixln2);
 427     # waggle command is      1010 1sss OSS wwwwV
 428     # so waggler objnum is   sss SS wwww
 429     $boardnum= (($boardnum & 0x07) << 2) | ($boardnum >> 3);
 430     return ($boardnum << $maxwaggleixln2) | $obj;
 431 }
 432
 433 sub boob2objnum_pt {
 434     my ($boob,$boardnum,$obj)=@_;
 435     mistake("point encoding out of range") if
 436         $boardnum >= (1 << (10 - $maxptixln2));
 437     die if $obj >= (1 << $maxptixln2);
 438     return ($boardnum << $maxptixln2) | $obj;
 439 }
 440
 441 sub boob2objnum_reverse {
 442     my ($boob,$orgboardnum,$obj,$boardtype)=@_;
 443     # Converts board and object number (in canonical pic number plus
 444     # and reverse0...reverse5 as seen on pinout diagrams), to the
 445     # segment number for POLARITY command numbered as shown in
 446     # README.protocol.
 447     #
 448     # There are three basic stages:
 449     #
 450     #  * We invert the on-board mapping; ie, we untangle the
 451     #    tangling between the message from master to slave pic
 452     #    and the actual pins (see reverse.asm, polarity_local_do)
 453     #
 454     #  * We figure out which bit of which message byte the
 455     #    object corresponds to.  (see reverse.asm, command_polarity)
 456     #
 457     #  * We compute the README.protocol segment number.
 458
 459     my ($cycle,$boardincycle,$cyclebasebyte,$byte,$bit,$boardnum,$rv);
 460     $boardnum= $reversersboardnum[$orgboardnum];
 461     die "$orgboardnum $boardnum" unless defined $boardnum;
 462     die "$orgboardnum $boardnum" unless $boardnum >= 0;
 463     die unless $boardtype eq 'reversers';
 464     die $obj if $obj > 5;
 465 #print STDERR "data2safety $boardnum.$obj ";
 466     $obj = sprintf '%d', $obj;
 467     $obj =~ y/302154/543210/; # mapping due to polarity_do_here
 468 #print STDERR " obj=$obj";
 469     $cycle= int(($boardnum+3) / 7);
 470 #print STDERR " cycle=$cycle";
 471     $boardincycle= ($boardnum+3) - $cycle*7;
 472 #print STDERR " boardin=$boardincycle";
 473     $cyclebasebyte= $cycle*6 - 2;
 474 #print STDERR " baseby=$cyclebasebyte";
 475     if ($boardnum==2 && $obj > 2) {
 476         $byte= 0; $bit= $obj-3;
 477         $rv= 3 - $bit; # only these three in byte 0, a special case;
 478 #print STDERR " special bit=$bit => $rv\n";
 479         return $rv;
 480     } elsif ($boardincycle<5) {
 481         $byte= $cyclebasebyte + $boardincycle; $bit= $obj + 1;
 482     } elsif ($boardincycle==6) {
 483         $byte= $cyclebasebyte + 5; $bit= $obj + 1;
 484     } elsif ($boardincycle==5) {
 485         $byte= $cyclebasebyte + 5 - $bit; $bit= 0;
 486     } else {
 487         die;
 488     }
 489     $rv= $byte*7 + 3 - $bit;
 490 #print STDERR " ordinary byte=$byte bit=$bit => $rv\n";
 491     return $rv;
 492 }
 493
 494 sub boob2objnum_sense {
 495     my ($boob,$boardnum,$obj)= @_;
 496     my $type= $boardtype[$boardnum];
 497     my $bitnum= $sensepermute{$type}[$obj];
 498     die "$type $obj ($boardnum)" unless defined $bitnum;
 499     my $base= $sensesbase[$boardnum];
 500     my $inpage= $base & 0x7f;
 501     die if $inpage+$bitnum > 127;
 502     return $base+$bitnum;
 503 }
 504
 505 sub boob2objnum ($$) {
 506     my ($mkused,$boob) = @_;
 507     my ($kind,$boardnum,$type);
 508     $kind= $boob->{Kind};
 509     $boardnum= $boob->{Board};
 510 #use Data::Dumper;
 511 #print STDERR "boob2objnum($mkused, ", Dumper($boob), " )\n";
 512     $type= $boardtype[$boardnum];
 513     return &{"boob2objnum_$kind"}
 514         ($boob, $boardnum, $boob->{Obj}, $type, $mkused);
 515 }
 516
 517 sub boob_used ($) {
 518     my ($boob) = @_;
 519     my ($objnum);
 520     $objnum= boob2objnum(0, $boob);
 521     return $pin_used{$boob->{Kind}}[$objnum];
 522 }
 523
 524 sub boob_used_bit ($) {
 525     my ($boob) = @_;
 526     return defined boob_used($boob) ? 1 : 0;
 527 }
 528
 529 sub boardtype ($) {
 530     my ($board)=@_;
 531 #print STDERR ">$board<\n";
 532     mistake("unknown board number $board") unless defined $boardtype[$board];
 533     return $boardtype[$board];
 534 }
 535
 536 sub kind2genkind ($) {
 537     my ($k) = @_;
 538     return 'indiv' if $k eq 'waggle';
 539     return $k;
 540 }
 541
 542 sub boob2genkind ($) {
 543     my ($boob) = @_;
 544     return kind2genkind($boob->{Kind});
 545 }
 546
 547 sub so_boob ($$;$) {
 548     my ($mkused,$bo, $objnum_rr) = @_;
 549     my ($type,$objnum,$pi,$genkind);
 550     if (defined $bo) {
 551         my ($kind,$board,$obj) = map { $bo->{$_} } qw(Kind Board Obj);
 552 #print STDERR "so_boob >$kind|$board$obj<\n";
 553         $genkind= boob2genkind($bo);
 554 #print STDERR "so_boob    >$board|$obj<\n";
 555         $type= boardtype($board);
 556         $pi= $pin_info{$type}{$genkind};
 557         mistake("object reference $genkind ($kind) $board.$obj out of range".
 558                 " for board type $type")
 559             unless defined $pi->[$obj];
 560 #print STDERR "so_boob >$kind|$board $obj|$pi->[$obj]<\n" if $kind eq 'waggle';
 561         $objnum= boob2objnum($mkused,$bo);
 562 #print "so_boob >$objnum_rr|$$objnum_rr< = $objnum\n";
 563         $$objnum_rr= $objnum;
 564         $pin_used{$kind}[$objnum]= [ $board, $pi->[$obj], $obj ]
 565             if $mkused;
 566         return sprintf("%#5x /* %d.%-*d*/", $objnum, $board,
 567                        $kind eq 'reverse' ? 1 : 2, $obj);
 568     } else {
 569 #print "so_boob >$objnum_rr|$$objnum_rr< -\n";
 570         return "    0 /*none*/ ";
 571     }
 572 }
 573
 574 sub so_objboob ($$;$) {
 575     my ($mkused,$obj,$objnum_rr) = @_;
 576     return so_boob($mkused, defined $obj ? $obj->{BoOb} : undef,
 577                    $objnum_rr);
 578 }
 579
 580 sub mainread () {
 581     $mistakes= 0;
 582     while (<>) {
 583         chomp;
 584         s/\#.*//;
 585         s/\s+$//;
 586         next unless m/\S/;
 587         last if m/^end$/;
 588         if (m/^(invertible|vanilla|points|relays|fixed|endwiring|boards|interferences|movfeatposmap)$/) {
 589             $mode= $1;
 590             $invertible= ($mode eq 'invertible');
 591             $mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
 592             &{"begin_$mode"};
 593         } else {
 594             $currentline= $_;
 595             &{"line_$mode"};
 596         }
 597     }
 598 }
 599
 600 sub redact_indir ($$) {
 601     my ($r, $what)= @_;
 602 #use Data::Dumper;
 603 #print STDERR "redact ", Dumper($r), "\n";
 604     return unless exists $r->{Indiv};
 605     my ($board,$indiv);
 606     $board= $r->{Board};
 607     $indiv= $r->{Indiv};
 608 #print STDERR "redact >$board|$indiv<\n";
 609     my $boardtype= boardtype($board);
 610     if (defined $pin_info_indiv{$boardtype}{$indiv}) {
 611         $r->{Obj}= $pin_info_indiv{$boardtype}{$indiv};
 612     } else {
 613         mistake("unknown pin name $boardtype.$indiv for $what");
 614         $r->{Obj}= 0;
 615     }
 616 }
 617
 618 sub record_phys_pin_used ($$) {
 619     my ($r,$whatfor) = @_;
 620     my ($board,$obj,$kind,$type,$pi);
 621     our (%phys_pin_used);
 622     $obj= $r->{Obj};
 623     return if $obj==0 && $mistakes; # false positives, otherwise
 624     $board= $r->{Board};
 625     $kind= kind2genkind($r->{Kind});
 626     $type= $boardtype[$board];
 627     $whatfor .= " ($r->{Kind} $kind $obj)";
 628     $pi= $pin_info{$type}{$kind}[$obj];
 629     $pi =~ m/^([01234]),(\d),/ or die $!;
 630     my ($port,$bit)=($1,$2);
 631     if (exists $phys_pin_used{$board,$pi} &&
 632         $phys_pin_used{$board,$pi} ne $whatfor) {
 633         mistake("board $board physical pin ".
 634                 "R".(qw(A B C D E)[$port]).$bit.
 635                 " ($pi) used more than once:\n".
 636                 "  $phys_pin_used{$board,$pi};\n".
 637                 "  $whatfor");
 638     }
 639     $phys_pin_used{$board,$pi}= $whatfor;
 640 }
 641
 642 sub redaction () {
 643     my ($num,$mappednum,$i,$objnum);
 644     $maxreverseobjnum= 0;
 645     for ($num=0, $mappednum=0; $num<@boardtype; $num++) {
 646         next unless defined $reversersboardnum[$num];
 647         die if $reversersboardnum[$num] != -1;
 648         $reversersboardnum[$num]= $mappednum;
 649         for ($i=0; $i<6; $i++) {
 650             $objnum= boob2objnum(0, { Kind => 'reverse',
 651                                       Board => $num,
 652                                       Obj => $i });
 653             $maxreverseobjnum= $objnum+1 if $objnum >= $maxreverseobjnum;
 654         }
 655         $mappednum++;
 656     }
 657     my ($seg,$segr,$feat,$featr,$board,$indir,$boardtype,$why);
 658     foreach $seg (keys %segs) {
 659         $segr= $segs{$seg};
 660         foreach $feat (keys %{ $segr->{Feats} }) {
 661             $featr= $segr->{Feats}{$feat};
 662             map {
 663                 $why= "segment $featr->{Kind} $seg/$feat";
 664                 redact_indir($_,$why);
 665                 record_phys_pin_used($_, $why);
 666             } @{ $featr->{BoObs} };
 667         }
 668     }
 669 }
 670
 671 sub nummap ($) {
 672     my ($p) = @_;
 673     $p =~ s/\d{1,6}/ sprintf "%06d%d",$&,$& /ge;
 674     return $p;
 675 }
 676
 677 sub so_segnum ($) {
 678     return sprintf "s%s", $_[0];
 679 }
 680
 681 sub writeout () {
 682     my (@segs,$segn,$seg,$segr,$feat,$featv, $delim);
 683     my ($comb,$pi,$end,$boob);
 684     my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
 685     my ($ourinter,$pcname,$intere,$intother,$fixedi);
 686     o("/* autogenerated - do not edit */\n\n");
 687     @segs=();
 688     for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
 689         $segs{$seg}{Num}= @segs;
 690         push @segs, $seg;
 691     }
 692     o(sprintf
 693       "#define NUM_SEGMENTS %s\n\n".
 694       "#include \"layout-data.h\"\n\n",
 695       scalar @segs);
 696
 697     my ($segnum);
 698     $segnum= 0;
 699     foreach $seg (@segs) {
 700         o(sprintf "#define s%-4s %4d\n", $seg, $segnum);
 701         $segnum++;
 702     }
 703     o("\n");
 704
 705     foreach $seg (@segs) {
 706         $segr= $segs{$seg};
 707
 708         o("static const SegPosCombInfo spci_${seg}"."[]= {");
 709         $delim='';
 710
 711         $segr->{Inter}{Map}= 0;
 712         $segr->{Inter}{Invert}= 0;
 713         $ourinter= $segr->{Inter};
 714         for ($comb=0; $comb < $segr->{Posns}; $comb++) {
 715             $pi='';
 716             foreach $feat (sort keys %{ $segr->{Feats} }) {
 717                 $featv= $segr->{Feats}{$feat};
 718                 next if exists $featv->{Fixed};
 719                 $pi.= sprintf("%s%d", $feat,
 720                               ($comb / $featv->{Weight}) % $featv->{Posns});
 721             }
 722             my $pi_abstr= $pi;
 723             movfeatposmap(\$pi_abstr, $segr, Concrete, Abstract, sub { });
 724             $pi_abstr =~
 725             o("$delim\n");
 726             my $dist= $segr->{Dist}[$comb];
 727             o(sprintf " { %-7s%4d, { ",
 728               '"'.$pi_abstr.'",',
 729               defined($dist) ? $dist : 1);
 730             for ($end=0; $end<2; $end++) {
 731                 o(", ") if $end;
 732                 o("{");
 733                 $otherend= $segr->{Ends}[$comb][!$end];
 734                 if (!defined $otherend) {
 735                     die "segment $seg combination $comb end $end undefined\n"
 736                         if defined $dist;
 737                     o(" 0,NOTA(Segment)");
 738                 } else {
 739                     ($node,$side) = @$otherend;
 740                     $nodeotherside= $nodes{$node}[1-$side];
 741                     if (defined $nodeotherside) {
 742                         $otherseg= $nodeotherside->{Seg};
 743                         $otherbackrelus= $nodeotherside->{End} ^ $end;
 744                         o(sprintf "/*%4s.%d*/ %d,%4s",
 745                           $node,$side,
 746                           $otherbackrelus,
 747                           so_segnum($otherseg));
 748                     } else {
 749                         o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
 750                           $node,$side);
 751                     }
 752                 }
 753                 o(" }");
 754             }
 755             o(sprintf " } }");
 756             $delim= ',';
 757
 758             $pcname= "$seg/$pi";
 759             for $intere (@interfs) {
 760                 my ($inter)= $intere->{Segs};
 761                 next unless grep {
 762                     if ($pcname =~ m/^$_$/) {
 763                         s,/.*,/ ?,; 1;
 764                     } else {
 765                         0;
 766                     }
 767                 } @$inter;
 768                 for $intother (@$inter) {
 769                     $intother =~ m,^(\w+)/, or die "$intother ?";
 770                     next if $1 eq $seg;
 771                     exists $segs{$1} or
 772                         endmistake("unknown segment $1 in interference");
 773                     if (defined $ourinter->{Seg}) {
 774                         $1 eq $ourinter->{Seg} or
 775                             endmistake("unsupported complicated interference ".
 776                                        "involving $seg, $1, $ourinter->{Seg}");
 777                     } else {
 778                         $ourinter->{Seg}= $1;
 779                         $ourinter->{Invert}= $intere->{Invert};
 780                     }
 781                 }
 782                 endmistake("unsupported too-moveable interference")
 783                     if $comb>7;
 784                 $ourinter->{Map} |= 1 << $comb;
 785             }
 786         }
 787         o("\n};\n");
 788
 789         next unless $segr->{FeatCount} || $segr->{FeatCountFixed};
 790
 791         for $feat (keys %{ $segr->{Feats} }) {
 792             $featv= $segr->{Feats}{$feat};
 793             next if exists $featv->{Fixed};
 794             o("static const BoardObject mfbo_${seg}_${feat}"."[]= {");
 795             $delim=' ';
 796             foreach $boob (@{ $featv->{BoObs} }) {
 797                 o($delim);
 798                 o(so_boob(1, $boob));
 799                 $delim= ', ';
 800             }
 801             o(" };\n");
 802         }
 803
 804         o("static const MovFeatInfo mfi_${seg}"."[]= {");
 805         $delim='';
 806         for $fixedi (qw(0 1)) {
 807             for $feat (keys %{ $segr->{Feats} }) {
 808                 $featv= $segr->{Feats}{$feat};
 809                 next if $fixedi != !!exists $featv->{Fixed};
 810                 o("$delim\n");
 811                 o("  { \"$feat\", mfk_".lc($featv->{Kind}).",");
 812                 if (!$fixedi) {
 813                     o(" $featv->{Posns}, $featv->{Weight}, mfbo_${seg}_$feat");
 814                 } else {
 815                     o(" $featv->{Fixed}, 0, 0");
 816                 }
 817                 o(" }");
 818                 $delim=',';
 819             }
 820         }
 821         o("\n};\n");
 822     }
 823     for $intere (@interfs) {
 824         map {
 825             warn "warning: unused interference specification $_\n" unless m, ,;
 826         } @{ $intere->{Segs} };
 827     }
 828
 829     my (@sensemap,$sensenum,$i);
 830     o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
 831     o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
 832     $delim= '';
 833     $segnum= 0;
 834     foreach $seg (@segs) {
 835         $segr= $segs{$seg};
 836         o("$delim\n");
 837         my $sensesoboob= so_objboob(1, $segr, \$sensenum);
 838         o(sprintf " { %-7s%d,%d,%2d,%d,%-9s%d,%-10s%-6s,%-7s",
 839           "\"$seg\",",$segr->{InvBoOb}?1:0,$segr->{Inter}{Invert},
 840           $segr->{FeatCount}, $segr->{FeatCountFixed},
 841           ($segr->{FeatCount}||$segr->{FeatCountFixed}) ? "mfi_$seg," : '0,',
 842           $segr->{Posns}, "spci_$seg,",
 843           $sensesoboob,
 844           so_boob(1, $segr->{InvBoOb}).',');
 845         $ourinter= $segr->{Inter};
 846         if (defined $ourinter->{Seg}) {
 847             o(sprintf "%4s,0%o ", so_segnum($ourinter->{Seg}),
 848               $ourinter->{Map});
 849         } else {
 850             o(" -1 ");
 851         }
 852         o("}");
 853         $delim= ',';
 854         endmistake("sense $sensesoboob used for both".
 855                    " $seg and $sensemap[$sensenum]")
 856             if defined $sensemap[$sensenum];
 857         $sensemap[$sensenum]= $seg;
 858         $segnum++;
 859     }
 860     o("\n};\n");
 861     o("const BoardObject info_maxreverse= $maxreverseobjnum;\n");
 862     o("#define u -1\n");
 863     o("const SegmentNumInMap info_segmentmap[]= {\n");
 864     $i=0;
 865     foreach $seg (@sensemap) {
 866         o(!$i ? ' ' :
 867           !($i % 12) ? ",\n " :
 868           ",");
 869         o(defined($seg) ? sprintf("%4s",so_segnum($seg)) : '   u');
 870         $i++;
 871     }
 872     o("\n};\n".
 873       "#undef u\n".
 874       "const int info_segmentmaplen= ".scalar(@sensemap).";\n");
 875 }
 876
 877 # writeasm_KIND()
 878
 879 sub o_section ($$) {
 880     my ($sec,$docstring) = @_;
 881     o("\n;----------\n".
 882       "  org $sec\n");
 883     o($docstring);
 884 }
 885 sub o_section_end_fill ($$$) {
 886     my ($lastnumdone, $fillvalue, $entrysize) = @_;
 887     if ($entrysize == 1 and $lastnumdone & 1) {
 888         o(", $fillvalue & 0xff\n");
 889         $lastnumdone++;
 890     } else {
 891         o("\n");
 892     }
 893     o(sprintf "  fill %s, %d*(maxpics-%d)\n\n",
 894       $fillvalue, $entrysize, $lastnumdone);
 895 }
 896
 897 sub o_db ($;$) {
 898     my ($ix,$every) = @_;
 899     $every=16 unless defined $every;
 900     o(($every ? $ix % $every : $ix) ? ',' : "\n  db ");
 901 }
 902
 903 sub writeasm_sense {
 904     my ($num, $base);
 905     o_section('pic2detinfo',<<'END');
 906 ; Table indexed by pic no., giving information about sensing
 907 ; Each element is two bytes:
 908 ;  1st byte   bit 7     Set iff this board exists for the purposes of sensing
 909 ;             bits 6-3  Not used, set to zero
 910 ;             bits 2-0  Top 3 bits of sense segment numbers on this board
 911 ;  2nd byte   bit 7     Set iff this board is a Detectors board
 912 ;             bits 6-0  Base for bottom 7 bits of segment number
 913 ;                       (per-board segment no. is added to this; carry
 914 ;                        to upper 3 bits is not permitted)
 915 END
 916     o("SenseExists equ 0x80\n".
 917       "Detectors equ 0x80\n".
 918       "Reversers equ 0x00\n\n");
 919     for ($num=0; $num<@boardtype; $num++) {
 920         if (!defined $boardtype[$num]) { o("  dw  0\t\t\t\t; $num\n"); next; }
 921         $base= $sensesbase[$num];
 922         o(sprintf "  db  SenseExists | 0x%02x, %12s | 0x%02x\t; %d\n",
 923           $base >> 7, ucfirst($boardtype[$num]), $base & 0x7f, $num);
 924     }
 925     o_section_end_fill($num, 0, 2);
 926 }
 927
 928 sub writeasm_pt ($$) { writeasm_ptwag('pt',$maxptixln2); }
 929 sub writeasm_waggle ($$) { writeasm_ptwag('waggle',$maxwaggleixln2); }
 930 sub writeasm_ptwag ($$) {
 931     my ($ptwag, $maxthingixln2) = @_;
 932     my $bitmapbitsperpic= 1<<$maxthingixln2;
 933     my $bitmapbytesperpic= 1<<($maxthingixln2-3);
 934     my ($num, $elemsize, $byte, $bit, $objnum);
 935
 936     o_section("picno2${ptwag}map",<<"END");
 937 ; Bitmap indexed first by pic no, and then by thing no. on that board,
 938 ; saying whether the thing is present or not.  Each pic has
 939 ; $bitmapbytesperpic bytes, ie $bitmapbitsperpic bits.  First byte is
 940 ; objects 0 to 7, in bits 0 to 7 respectively so that MSbit of byte 3
 941 ; (4th byte) is object no.31.  Unused boards or boards with no such
 942 ; objects are all-bits-0.
 943 END
 944     for ($num=0; $num<@boardtype; $num++) {
 945         if (!defined $boardtype[$num]) { o("  dw  0\t\t\t\t; $num"); next; }
 946         die if $maxthingixln2 < 4; # must be whole no. of 16-bit words
 947         $elemsize= $bitmapbytesperpic;
 948         for ($byte=0; $byte < $elemsize; $byte++) {
 949             o_db($byte, 0);
 950             o("b'");
 951             for ($bit=7; $bit>=0; $bit--) {
 952                 o(boob_used_bit({ Kind => $ptwag,
 953                                   Board => $num,
 954                                   Obj => $byte*8 + $bit }));
 955             }
 956             o("'");
 957         }
 958         o(" ; $num");
 959     }
 960     o("\n");
 961     o_section_end_fill($num, 0, $elemsize);
 962
 963     my ($typeix,$type,$pi,$indexpr);
 964     $indexpr= '0'x(7-$maxthingixln2). 'D'. 'o'x$maxthingixln2;
 965     o_section("bk${ptwag}ix2portnumbitnum",<<"END");
 966 ; Table giving physical ports and pins for each $ptwag for each
 967 ; kind of board.  Index is object number (for reversers boards)
 968 ; or object number + 2^$maxthingixln2 (for detectors boards).
 969 ; Value is one byte, either 0xff meaning that board type has
 970 ; no such object, or top nybble being port number (0 for A, 1 for B,
 971 ; etc.) and bottom nybble being bit number.  Ie,
 972 ;   Index:  $indexpr    where D is 1 iff detectors board and o is obj
 973 ;   Value:  0ppp0bbb    where p is port num and b is bit num; or 0xff
 974 END
 975     o("  radix hex\n");
 976     for ($typeix=0; $typeix<2; $typeix++) {
 977         $type= qw(reversers detectors)[$typeix];
 978         die $type unless $pin_info{$type};
 979         o("; $type:");
 980         for ($objnum=0; $objnum < (1 << $maxthingixln2); $objnum++) {
 981             o_db($objnum);
 982             $pi= $pin_info{$type}{kind2genkind($ptwag)}[$objnum];
 983             if (defined $pi) {
 984                 $pi =~ m/^(\d)\,(\d)\,/ or die;
 985                 o($1.$2);
 986             } else {
 987                 o('ff');
 988             }
 989         }
 990         o("\n");
 991     }
 992     o("  radix dec\n\n");
 993 }
 994
 995 sub writeasm_reverse {
 996     my ($num,$kc,$bit, @portae,$pu);
 997     o_section('picno2revmasks',<<END);
 998 ; Table listing which reversers are connected/enabled.  Index is pic
 999 ; number.  Each entry is 2 bytes: mask for port A followed by mask for
1000 ; port E.  A 1 bit is a connected reverser.  Both masks are 0 for
1001 ; non-reversers boards.
1002 END
1003     for ($num=0; $num<@boardtype; $num++) {
1004         @portae= ([],[]);
1005         $kc= $kind_count{$boardtype[$num]}{'reverse'};
1006         for ($bit= $kc-1; $bit>=0; $bit--) {
1007             $pu= boob_used({ Board => $num,
1008                              Obj => $bit,
1009                              Kind => 'reverse' });
1010             next unless $pu;
1011             $pu->[1] =~ m/^([04])\,\d,(0x\w{2})$/ or die;
1012             push @{ $portae[!!$1] }, $2;
1013         }
1014         o('  db ');
1015         o(join(', ', map { @$_ ? join('|',@$_) : '0' } @portae));
1016         o(sprintf " ; %d\n",$num);
1017     }
1018     o_section_end_fill($num, '0x0000', 2);
1019 }
1020
1021 sub writeasm () {
1022     my ($k,$w,$i,@d,$or,$p,$portnum,$bit,$each);
1023     close STDOUT or die $!;
1024     open STDOUT, ">$basename+pindata.asm" or die $!;
1025     o("; autogenerated - do not edit\n");
1026     o("  include pindata.inc\n".
1027       "  radix dec\n".
1028       "ff equ 0xff\n");
1029     $each= 10;
1030     for $k (@objkinds) {
1031         &{"writeasm_$k"}();
1032     }
1033     o("\n  end\n");
1034 }
1035
1036 sub writeforui () {
1037     close STDOUT or die $!;
1038     open STDOUT, ">$basename.dgram.segmap-info" or die $!;
1039     o("# autogenerated - do not edit\n");
1040     foreach my $seg (keys %segs) {
1041         my $segr= $segs{$seg};
1042         my $featmap= $segr->{FeatMap};
1043         next unless $featmap;
1044         foreach my $mapent (@$featmap) {
1045             o("layout-subseg-featmap $seg $mapent->{Abstract}");
1046             local ($_) = $mapent->{Concrete};
1047             s/([A-Z]+)(\d+)/  o(" $1 $2"); "";  /ge;
1048             die "$seg $_ ?" if length;
1049             o("\n");
1050         }
1051     }
1052 }
1053
1054 mainread();
1055 redaction();
1056 writeout();
1057 writeasm();
1058 writeforui();
1059 movfeatposmap_checks();
1060 exit 1 if $mistakes;