#!/usr/bin/perl -w

use strict qw(vars);

our ($basename);
$basename= @ARGV ? $ARGV[0] : 'safety';
die if $basename =~ m/^\-/;
$basename =~ s/\.wiring$//;

our ($mistakes, $currentline);

our (%segs);
# ->{BoOb}{Kind}  'pt' 'sense' 'reverse' 'waggle'
# ->{BoOb}{Board}
# ->{BoOb}{Obj}
# ->{BoOb}{Indiv}   for `indiv' board objects like wagglers
# $segs{$seg}{InvBoOb}
# $segs{$seg}{BoOb}
# $segs{$seg}{Posns}
# $segs{$seg}{FeatCount}                does not include Fixed
# $segs{$seg}{FeatCountFixed}
# $segs{$seg}{Feats}{$feat}{Kind}       Point, Fixed, or Relay
# $segs{$seg}{Feats}{$feat}{Weight}     ) for Point or Relay only
# $segs{$seg}{Feats}{$feat}{Posns}      ) for Point or Relay only
# $segs{$seg}{Feats}{$feat}{BoObs}[]    ) for Point or Relay only
# $segs{$seg}{Feats}{$feat}{Fixed}      position, for Fixed only
# $segs{$seg}{FeatMap}[]{Abstract}	as from ours.m4
# $segs{$seg}{FeatMap}[]{Concrete}	as in ours.wiring, for safety:movpos.c
# $segs{$seg}{FeatMap}[]{UsedAbstract}
# $segs{$seg}{FeatMap}[]{UsedConcrete}
# $segs{$seg}{Inter}{Seg}	        ) calculated
# $segs{$seg}{Inter}{Map}               )  in writeout

# $segs{$seg}{Num}
# $segs{$seg}{Ends}[$combpos][$end] = [ $node,$side ]
# $segs{$seg}{Dist}[$combpos]

our (@interfs);
# $interfs[]{Invert} = $invert 
# $interfs[]{Segs}[] = "$seg/$posre"   "/.*" added during parsing if necc.

our (%nodes);
# $nodes{$node}[$side]{Seg}
# $nodes{$node}[$side]{End}

our ($maxptixln2) = 5;
our ($maxwaggleixln2) = 4;

our ($nextboardnum,@boardtype,@sensesin,$maxreverseobjnum);
our (@reversersboardnum,@sensesbase,@objkinds,%pin_used);
# $boardtype[$boardnum]
# $sensesin[$page]
# $maxreverseobjnum
# $reversersboardnum[$boardnum]  # undef => none; -1 => not yet determined
# $sensesbase[$boardnum]= ($page << 7) | $baselsbyte
# $pin_used{$objkind}[$objnum] = [ $boardnum, $pin_info, $objonboard ]
$nextboardnum= 0;
$sensesin[0]= 0;
@objkinds= qw(pt sense reverse waggle);

our (%kind_count,%pin_info,%pin_info_indiv); # from BOARD.pin-info

our ($mode,$invertible);
$mode= 'barf';

our (%sensepermute);
# $sensepermute{$boardtype}[$objonboard]= $offset

sub sensepermute_bitmap ($$$) {
    my ($kind,$base,$mapstring) = @_;
    my ($objnum,$bitnum);
    my (@map)= split /\s+/, $mapstring;
    @map==8 or die;
    $bitnum= $base;
    while (@map) {
	$objnum= pop @map;
	next if $objnum =~ m/[a-z]/i;
	$objnum =~ m/^\d\d$/ or die "$kind $objnum ($bitnum) ?";
	$objnum =~ s/^0*\B//;
	die "$kind $objnum ($bitnum from $base)" if
	    defined $sensepermute{$kind}[$objnum];
	$sensepermute{$kind}[$objnum]= $bitnum;
#print STDERR "SPM $kind $objnum $bitnum\n";
	$bitnum++;
    }
}
# see detect.asm:
sensepermute_bitmap('reversers',  0, 'MM zz 01 02  03 00 04 05');
sensepermute_bitmap('detectors',  0, 'MM 05 B2 B1  10 13 16 08');
sensepermute_bitmap('detectors',  5, '19 09 12 15  18 04 20 17');
sensepermute_bitmap('detectors', 13, '06 01 07 02  11 14 03 00');

sub line_barf () {
    return if $mistakes;
    mistake("first input line does not determine phase");
}

sub syntaxerror () {
    our (%syntaxerror_once);
    return if exists $syntaxerror_once{$mode};
    $syntaxerror_once{$mode}= 1;
    mistake("syntax error");
    return undef;
}

sub ditch ($) {
    my ($m) = @_;
    print STDERR "info: ditching $m\n";
}

sub seg_wiring ($$$) {
    my ($seg,$feat,$hash) = @_;
    if (!exists $segs{$seg}) {
	foreach my $bo (@{ $hash->{BoObs} }) {
	    so_boob(1,$bo);
	}
	ditch("unwired segment for wired point $seg/$feat");
	return;
    }
    mistake("duplicate wiring for $seg/$feat")
	if exists $segs{$seg}{Feats}{$feat};
    if (exists $hash->{Posns}) {
	$hash->{Weight}= $segs{$seg}{Posns};
	$segs{$seg}{Posns} *= 2;
	$segs{$seg}{FeatCount}++;
    }
    $segs{$seg}{Feats}{$feat}= $hash;
}

sub begin_points () { }
sub line_points () {
    my ($seg,$pt,@boobstr,$bodef,@boobs);
    m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
	return syntaxerror();
    ($seg,$pt,$boobstr[0],$bodef,$boobstr[1])=($1,$2,$3,$4,$5);
    $boobstr[1] =~ s/^\./$bodef./;
    @boobs= map { pa_boob('pt',$_) } @boobstr;
    seg_wiring($seg,$pt, {
	Kind => Point,
	Posns => 2,
	BoObs => [ @boobs ],
    });
}

sub begin_relays () { }
sub line_relays () {
    my ($seg,$rly,$waggle);
    m,^\s+(\w+)/([A-Za-z]+)\s+([1-9]\d*|0)\.(\w+)$, or return syntaxerror();
    ($seg,$rly)= ($1,$2);
    $waggle= { Kind => 'waggle', Board => $3, Indiv => $4 };
    seg_wiring($seg,$rly, {
	Kind => Relay,
	Posns => 2,
	BoObs => [ $waggle ],
    });
}    

sub begin_fixed () { }
sub line_fixed () {
    my ($seg,$feat,$pos);
    m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
    ($seg,$feat,$pos)=($1,$2,$3);
    seg_wiring($seg,$feat, {
	Kind => Fixed,
	Fixed => $pos,
    });
    $segs{$seg}{FeatCountFixed}++;
}

sub begin_segment () { }
sub line_segment () {
    my ($seg,$boobstr,$boob);
    m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
    ($seg,$boobstr)=($1,$2);
    mistake("duplicate topology for segment $seg") if exists $segs{$seg};
    $boob= pa_boob('sense', $boobstr);
    $segs{$seg}= {
	BoOb => $boob,
	InvBoOb => $invertible ? { Kind => 'reverse',
				   Board => $boob->{Board},
				   Obj => $boob->{Obj} } : undef,
	Posns => 1,
	Feats => { },
	FeatCount => 0,
	FeatCountFixed => 0
    };
    &{"line_segment_".($invertible?'invertible':'vanilla')}($boob);
}

sub begin_endwiring () {
}

sub begin_boards () {
}
sub line_boards () {
    my ($num,$type,$k);
    m/^\s+(\d+)\s+(\w+)$/ or return syntaxerror();
    ($num,$type)=($1,$2);
    mistake("board $num when expected $nextboardnum")
	if $num != $nextboardnum;

    $nextboardnum++;
    $boardtype[$num]= $type;
    require "./$type.pin-info";

    my ($sense_count, $page);
    $sense_count= $kind_count{$type}{'sense'};
    for ($page=0;
	 $sensesin[$page] + $sense_count > 128;
	 $page++) {
	mistake("too many senses for encoding scheme")
	    if $page > 7;
	push @sensesin, 0
	    if $page > $#sensesin;
    }
    $sensesbase[$num]= ($page << 7) | $sensesin[$page];
    $sensesin[$page] += $sense_count;

    &{"line_boards_$type"}($num);
}

sub line_boards_reversers { }
sub line_boards_detectors { }
sub line_segment_vanilla ($) { }
sub line_segment_invertible ($) {
    my ($boob) = @_;
    $reversersboardnum[ $boob->{Board} ]= -1;
}

sub begin_interferences () {
}
sub line_interferences () {
    s/^\s+// or return syntaxerror();
    my ($is) = [ split /\s+/, $_ ];
    my ($invert)= 0;
    if ($is->[0] eq '-') {
	shift @$is;
	$invert= 1;
    }
    map {
	$invert ^= 1 if s/^\-//;
	s,$,/.*, unless m,/,;
    } @$is;
    return syntaxerror() if grep { !m,^\w+/, } @$is;
    push @interfs, { Invert => $invert, Segs => $is };
}

# We read the movfeatmap and write out most things in the output to
# have the concrete (RHS) version; the exception is layout-data.c
# SegPosCombInfo.pname.
#
# The FeatMap is a bidirectional mapping constructed from "movfeatposmap"
# lines, a map between ([A-Za-z]+[0-9]+)* and ([A-Za-z]+[0-9]+)*.
#
# It has two effects:
#     - in line_endwiring, used "forwards"
#     - when writing out .pname, used "backwards"
# in each case we match only whole feature positions by regexp tricks
# we record whether a mapping entry was used, and complain if not

sub begin_movfeatposmap () { }
sub line_movfeatposmap () {
    my ($segr,$abstr_namebase,$abstr_firstpos,$abstr_lastpos,$conc_posns) =
       m,^\s+(\w+)\s+([A-Za-z]+)(\d+)(?:\-(\d+))?((?:\s+(?:[A-Za-z]+\d+)*)+)$,;
    defined $segr or return syntaxerror();

    $abstr_lastpos= $abstr_firstpos unless defined $abstr_lastpos;
    my $nabstr_posns= $abstr_lastpos - $abstr_firstpos + 1;
    
    $conc_posns =~ s/^\s+//;
    my (@conc_posns) = split /\s+/, $conc_posns;

    my $seg= $segs{$segr};
    if (!$seg) {
	ditch("movfeatposmap for unwired segment".
	      " $segr/$abstr_namebase$abstr_firstpos".
	      ($nabstr_posns>1 ? "-$abstr_lastpos" : ""));
	return;
    }

    @conc_posns == $nabstr_posns
	or return mistake("number of concrete poscombs ".@conc_posns.
			  " differs from number of abstract poscombs".
			  " $nabstr_posns");
    for (my $i=0; $i<@conc_posns; $i++) {
	push @{ $seg->{FeatMap} }, {
	    Abstract => $abstr_namebase.($abstr_firstpos+$i),
	    Concrete => $conc_posns[$i],
	    Used => 0,
	};
    }
}

sub mistake ($) {
    my ($m) = @_;
    print STDERR "mistake: $m\n in $mode, \`$currentline'\n";
    $mistakes++;
}

sub endmistake ($) {
    my ($m) = @_;
    print STDERR "mistake: $m\n";
    $mistakes++;
}

sub movfeatposmap ($$$$$) {
    my ($subspecr, $segr, $entfrom, $entto, $call) = @_;
    my $featmap= $segr->{FeatMap};
    return unless $featmap;

    foreach my $mapent (@$featmap) {
	next unless
	    $$subspecr =~ s/
	        (?<! [A-Za-z] ) $mapent->{$entfrom} (?! \d )
	        /$mapent->{$entto}/x;
	$mapent->{"Used$entfrom"}++;
	$call->($mapent);
    }
}

sub movfeatposmap_checks () {
    foreach my $seg (keys %segs) {
	my $segr= $segs{$seg};
	my $featmap= $segr->{FeatMap};
	next unless $featmap;
	foreach my $mapent (@$featmap) {
	    foreach my $chk (qw(Abstract Concrete)) {
		next if $mapent->{"Used$chk"};
		endmistake("movfeatposmap entry $seg $mapent->{Abstract}".
			   " $mapent->{Concrete} unused for \L$chk lookup");
		last;
	    }
	}
    }
}

sub line_endwiring () {
    my (@ns,$seg,$subspec,$dist);
    my ($segr,@subsegil,$feat,$pos,$featr,$combpos,%featposwant);
    my ($end,$node,$side,$nsr,$endposr);
    m,^\s*segment\s+(\w+\.\d+)\s+(\w+\.\d+)\s+(\w+)(?:/((?:[A-Za-z]+\d+)+)\*\d+)?\s+([0-9.]+)$, or return syntaxerror();
    ($ns[0],$ns[1],$seg,$subspec,$dist)=($1,$2,$3,$4,$5);
    if (!exists $segs{$seg}) {
	ditch("unwired $seg".(defined $subspec ? "/$subspec" : ""));
	return;
    }
    $segr= $segs{$seg};
    my $desc= $seg;
    if (defined $subspec) {
	$desc .= "/$subspec";
	movfeatposmap(\$subspec, $segr, Abstract, Concrete, sub {
	    my ($mapent) = @_;
	    $desc .= "[$mapent->{Concrete}]";
	});
    }
    @subsegil= defined $subspec ? $subspec =~ m/([A-Za-z]+)(\d+)/g : ();
    while (@subsegil) {
	($feat,$pos,@subsegil) = @subsegil;
	if (!exists $segr->{Feats}{$feat}) {
	    mistake("no wiring for $seg/$feat");
	    next;
	}
	$featr= $segr->{Feats}{$feat};
	if (exists $featr->{Fixed}) {
	    if ($pos != $featr->{Fixed}) {
		ditch("fixed-elsewise $desc");
		return;
	    }
	} else {
	    mistake("position $seg/$feat$pos exceeds wiring")
		unless $pos < $featr->{Posns};
	    $featposwant{$feat}= $pos;
	}
    }
    $combpos= 0;
    for $feat (keys %{ $segr->{Feats} }) {
	$featr= $segr->{Feats}{$feat};
	next if exists $featr->{Fixed};
	mistake("wiring $seg/$feat not covered by $desc"),next
	    if !exists $featposwant{$feat};
	$combpos += $featposwant{$feat} * $featr->{Weight};
    }
    mistake("duplicate topology subseg for $desc")
	if defined $segs{$seg}{Dist}[$combpos];
    $segs{$seg}{Dist}[$combpos]= $dist;
    $endposr= $segr->{Ends}[$combpos];
    die "$seg $combpos ".(map { "@$_" } @$endposr)." ?"
	if defined $endposr && @$endposr;
    for ($end=0; $end<2; $end++) {
	$ns[$end] =~ m/^([a-z]\w+)\.([01])$/;
	($node,$side)=($1,$2);
	$nsr= $nodes{$node}[$side];
	if (!exists $nsr->{Seg}) {
	    $nodes{$node}[$side]= { Seg => $seg, End => $end };
	} else {
	    $seg eq $nsr->{Seg} or
		mistake("topology for $node.$side both $seg and $nsr->{Seg}");
	    $end == $nsr->{End} or
		mistake("topology for $node.$side $seg both ends ($end".
			" and also $nsr->{End})");
	}
	$segr->{Ends}[$combpos][$end]= [ $node, $side ];
    }
}

sub o ($) {
    print STDOUT $_[0] or die $!;
}

sub pa_boob ($$) {
    my ($kind,$str) = @_;
    if ($str !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
	mistake("invalid board object $str");
	return { Kind => $kind, Board => 0, Obj => 0 };
    }
    return { Kind => $kind, Board => $1, Obj => $2 };
}

# boob2objnum_KIND($boob,$boardnum,$objnum,$boardtype,$mkused ...)
#  -> global object number

sub boob2objnum_waggle {
    my ($boob,$boardnum,$obj) = @_;
    mistake("waggle encoding out of range") if
	$boardnum >= (1 << (9 - $maxwaggleixln2));
    die if $obj >= (1 << $maxwaggleixln2);
    # waggle command is      1010 1sss OSS wwwwV
    # so waggler objnum is   sss SS wwww
    $boardnum= (($boardnum & 0x07) << 2) | ($boardnum >> 3);
    return ($boardnum << $maxwaggleixln2) | $obj;
}

sub boob2objnum_pt {
    my ($boob,$boardnum,$obj)=@_;
    mistake("point encoding out of range") if
	$boardnum >= (1 << (10 - $maxptixln2));
    die if $obj >= (1 << $maxptixln2);
    return ($boardnum << $maxptixln2) | $obj;
}

sub boob2objnum_reverse {
    my ($boob,$orgboardnum,$obj,$boardtype)=@_;
    # Converts board and object number (in canonical pic number plus
    # and reverse0...reverse5 as seen on pinout diagrams), to the
    # segment number for POLARITY command numbered as shown in
    # README.protocol.
    #
    # There are three basic stages:
    #
    #  * We invert the on-board mapping; ie, we untangle the
    #    tangling between the message from master to slave pic
    #    and the actual pins (see reverse.asm, polarity_local_do)
    #
    #  * We figure out which bit of which message byte the
    #    object corresponds to.  (see reverse.asm, command_polarity)
    #
    #  * We compute the README.protocol segment number.
    
    my ($cycle,$boardincycle,$cyclebasebyte,$byte,$bit,$boardnum,$rv);
    $boardnum= $reversersboardnum[$orgboardnum];
    die "$orgboardnum $boardnum" unless defined $boardnum;
    die "$orgboardnum $boardnum" unless $boardnum >= 0;
    die unless $boardtype eq 'reversers';
    die $obj if $obj > 5;
#print STDERR "data2safety $boardnum.$obj ";
    $obj = sprintf '%d', $obj;
    $obj =~ y/302154/543210/; # mapping due to polarity_do_here
#print STDERR " obj=$obj";
    $cycle= int(($boardnum+3) / 7);
#print STDERR " cycle=$cycle";
    $boardincycle= ($boardnum+3) - $cycle*7;
#print STDERR " boardin=$boardincycle";
    $cyclebasebyte= $cycle*6 - 2;
#print STDERR " baseby=$cyclebasebyte";
    if ($boardnum==2 && $obj > 2) {
	$byte= 0; $bit= $obj-3;
	$rv= 3 - $bit; # only these three in byte 0, a special case;
#print STDERR " special bit=$bit => $rv\n";
	return $rv;
    } elsif ($boardincycle<5) {
	$byte= $cyclebasebyte + $boardincycle; $bit= $obj + 1;
    } elsif ($boardincycle==6) {
	$byte= $cyclebasebyte + 5; $bit= $obj + 1;
    } elsif ($boardincycle==5) {
	$byte= $cyclebasebyte + 5 - $bit; $bit= 0;
    } else {
	die;
    }
    $rv= $byte*7 + 3 - $bit;
#print STDERR " ordinary byte=$byte bit=$bit => $rv\n";
    return $rv;
}

sub boob2objnum_sense {
    my ($boob,$boardnum,$obj)= @_;
    my $type= $boardtype[$boardnum];
    my $bitnum= $sensepermute{$type}[$obj];
    die "$type $obj ($boardnum)" unless defined $bitnum;
    my $base= $sensesbase[$boardnum];
    my $inpage= $base & 0x7f;
    die if $inpage+$bitnum > 127;
    return $base+$bitnum;
}    

sub boob2objnum ($$) {
    my ($mkused,$boob) = @_;
    my ($kind,$boardnum,$type);
    $kind= $boob->{Kind};
    $boardnum= $boob->{Board};
#use Data::Dumper;
#print STDERR "boob2objnum($mkused, ", Dumper($boob), " )\n";
    $type= $boardtype[$boardnum];
    return &{"boob2objnum_$kind"}
        ($boob, $boardnum, $boob->{Obj}, $type, $mkused);
}

sub boob_used ($) {
    my ($boob) = @_;
    my ($objnum);
    $objnum= boob2objnum(0, $boob);
    return $pin_used{$boob->{Kind}}[$objnum];
}

sub boob_used_bit ($) {
    my ($boob) = @_;
    return defined boob_used($boob) ? 1 : 0;
}

sub boardtype ($) {
    my ($board)=@_;
#print STDERR ">$board<\n";
    mistake("unknown board number $board") unless defined $boardtype[$board];
    return $boardtype[$board];
}

sub kind2genkind ($) {
    my ($k) = @_;
    return 'indiv' if $k eq 'waggle';
    return $k;
}

sub boob2genkind ($) {
    my ($boob) = @_;
    return kind2genkind($boob->{Kind});
}

sub so_boob ($$;$) {
    my ($mkused,$bo, $objnum_rr) = @_;
    my ($type,$objnum,$pi,$genkind);
    if (defined $bo) {
	my ($kind,$board,$obj) = map { $bo->{$_} } qw(Kind Board Obj);
#print STDERR "so_boob >$kind|$board$obj<\n";
	$genkind= boob2genkind($bo);
#print STDERR "so_boob    >$board|$obj<\n";
	$type= boardtype($board);
	$pi= $pin_info{$type}{$genkind};
	mistake("object reference $genkind ($kind) $board.$obj out of range".
		" for board type $type")
	    unless defined $pi->[$obj];
#print STDERR "so_boob >$kind|$board $obj|$pi->[$obj]<\n" if $kind eq 'waggle';
	$objnum= boob2objnum($mkused,$bo);
#print "so_boob >$objnum_rr|$$objnum_rr< = $objnum\n";
	$$objnum_rr= $objnum;
	$pin_used{$kind}[$objnum]= [ $board, $pi->[$obj], $obj ]
	    if $mkused;
	return sprintf("%#5x /* %d.%-*d*/", $objnum, $board,
		       $kind eq 'reverse' ? 1 : 2, $obj);
    } else {
#print "so_boob >$objnum_rr|$$objnum_rr< -\n";
	return "    0 /*none*/ ";
    }
}

sub so_objboob ($$;$) {
    my ($mkused,$obj,$objnum_rr) = @_;
    return so_boob($mkused, defined $obj ? $obj->{BoOb} : undef,
		   $objnum_rr);
}

sub mainread () {
    $mistakes= 0;
    while (<>) {
	chomp;
	s/\#.*//;
	s/\s+$//;
	next unless m/\S/;
	last if m/^end$/;
	if (m/^(invertible|vanilla|points|relays|fixed|endwiring|boards|interferences|movfeatposmap)$/) {
	    $mode= $1;
	    $invertible= ($mode eq 'invertible');
	    $mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
	    &{"begin_$mode"};
	} else {
	    $currentline= $_;
	    &{"line_$mode"};
	}
    }
}

sub redact_indir ($$) {
    my ($r, $what)= @_;
#use Data::Dumper;
#print STDERR "redact ", Dumper($r), "\n";
    return unless exists $r->{Indiv};
    my ($board,$indiv);
    $board= $r->{Board};
    $indiv= $r->{Indiv};
#print STDERR "redact >$board|$indiv<\n";
    my $boardtype= boardtype($board);
    if (defined $pin_info_indiv{$boardtype}{$indiv}) {
	$r->{Obj}= $pin_info_indiv{$boardtype}{$indiv};
    } else {
	mistake("unknown pin name $boardtype.$indiv for $what");
	$r->{Obj}= 0;
    }
}

sub record_phys_pin_used ($$) {
    my ($r,$whatfor) = @_;
    my ($board,$obj,$kind,$type,$pi);
    our (%phys_pin_used);
    $obj= $r->{Obj};
    return if $obj==0 && $mistakes; # false positives, otherwise
    $board= $r->{Board};
    $kind= kind2genkind($r->{Kind});
    $type= $boardtype[$board];
    $whatfor .= " ($r->{Kind} $kind $obj)";
    $pi= $pin_info{$type}{$kind}[$obj];
    $pi =~ m/^([01234]),(\d),/ or die $!;
    my ($port,$bit)=($1,$2);
    if (exists $phys_pin_used{$board,$pi} &&
	$phys_pin_used{$board,$pi} ne $whatfor) {
	mistake("board $board physical pin ".
		"R".(qw(A B C D E)[$port]).$bit.
		" ($pi) used more than once:\n".
		"  $phys_pin_used{$board,$pi};\n".
		"  $whatfor");
    }
    $phys_pin_used{$board,$pi}= $whatfor;
}

sub redaction () {
    my ($num,$mappednum,$i,$objnum);
    $maxreverseobjnum= 0;
    for ($num=0, $mappednum=0; $num<@boardtype; $num++) {
	next unless defined $reversersboardnum[$num];
	die if $reversersboardnum[$num] != -1;
	$reversersboardnum[$num]= $mappednum;
	for ($i=0; $i<6; $i++) {
	    $objnum= boob2objnum(0, { Kind => 'reverse',
				      Board => $num,
				      Obj => $i });
	    $maxreverseobjnum= $objnum+1 if $objnum >= $maxreverseobjnum;
	}
	$mappednum++;
    }
    my ($seg,$segr,$feat,$featr,$board,$indir,$boardtype,$why);
    foreach $seg (keys %segs) {
	$segr= $segs{$seg};
	foreach $feat (keys %{ $segr->{Feats} }) {
	    $featr= $segr->{Feats}{$feat};
	    map {
		$why= "segment $featr->{Kind} $seg/$feat";
		redact_indir($_,$why);
		record_phys_pin_used($_, $why);
	    } @{ $featr->{BoObs} };
	}
    }
}

sub nummap ($) {
    my ($p) = @_;
    $p =~ s/\d{1,6}/ sprintf "%06d%d",$&,$& /ge;
    return $p;
}

sub so_segnum ($) {
    return sprintf "s%s", $_[0];
}

sub writeout () {
    my (@segs,$segn,$seg,$segr,$feat,$featv, $delim);
    my ($comb,$pi,$end,$boob);
    my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
    my ($ourinter,$pcname,$intere,$intother,$fixedi);
    o("/* autogenerated - do not edit */\n\n");
    @segs=();
    for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
	$segs{$seg}{Num}= @segs;
	push @segs, $seg;
    }
    o(sprintf
      "#define NUM_SEGMENTS %s\n\n".
      "#include \"layout-data.h\"\n\n",
      scalar @segs);

    my ($segnum);
    $segnum= 0;
    foreach $seg (@segs) {
	o(sprintf "#define s%-4s %4d\n", $seg, $segnum);
	$segnum++;
    }
    o("\n");

    foreach $seg (@segs) {
	$segr= $segs{$seg};

	o("static const SegPosCombInfo spci_${seg}"."[]= {");
	$delim='';

	$segr->{Inter}{Map}= 0;
	$segr->{Inter}{Invert}= 0;
	$ourinter= $segr->{Inter};
	for ($comb=0; $comb < $segr->{Posns}; $comb++) {
	    $pi='';
	    foreach $feat (sort keys %{ $segr->{Feats} }) {
		$featv= $segr->{Feats}{$feat};
		next if exists $featv->{Fixed};
		$pi.= sprintf("%s%d", $feat,
			      ($comb / $featv->{Weight}) % $featv->{Posns});
	    }
	    my $pi_abstr= $pi;
	    movfeatposmap(\$pi_abstr, $segr, Concrete, Abstract, sub { });
	    $pi_abstr =~ 
	    o("$delim\n");
	    my $dist= $segr->{Dist}[$comb];
	    o(sprintf " { %-7s%4d, { ",
	      '"'.$pi_abstr.'",',
	      defined($dist) ? $dist : 1);
	    for ($end=0; $end<2; $end++) {
		o(", ") if $end;
		o("{");
		$otherend= $segr->{Ends}[$comb][!$end];
		if (!defined $otherend) {
		    die "segment $seg combination $comb end $end undefined\n"
			if defined $dist;
		    o(" 0,NOTA(Segment)");
		} else {
		    ($node,$side) = @$otherend;
		    $nodeotherside= $nodes{$node}[1-$side];
		    if (defined $nodeotherside) {
			$otherseg= $nodeotherside->{Seg};
			$otherbackrelus= $nodeotherside->{End} ^ $end;
			o(sprintf "/*%4s.%d*/ %d,%4s",
			  $node,$side,
			  $otherbackrelus,
			  so_segnum($otherseg));
		    } else {
			o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
			  $node,$side);
		    }
		}
		o(" }");
	    }
	    o(sprintf " } }");
	    $delim= ',';

	    $pcname= "$seg/$pi";
	    for $intere (@interfs) {
		my ($inter)= $intere->{Segs};
		next unless grep {
		    if ($pcname =~ m/^$_$/) {
			s,/.*,/ ?,; 1;
		    } else {
			0;
		    }
		} @$inter;
		for $intother (@$inter) {
		    $intother =~ m,^(\w+)/, or die "$intother ?";
		    next if $1 eq $seg;
		    exists $segs{$1} or
			endmistake("unknown segment $1 in interference");
		    if (defined $ourinter->{Seg}) {
			$1 eq $ourinter->{Seg} or
			    endmistake("unsupported complicated interference ".
				       "involving $seg, $1, $ourinter->{Seg}");
		    } else {
			$ourinter->{Seg}= $1;
			$ourinter->{Invert}= $intere->{Invert};
		    }
		}
		endmistake("unsupported too-moveable interference")
		    if $comb>7;
		$ourinter->{Map} |= 1 << $comb;
	    }
	}
	o("\n};\n");

	next unless $segr->{FeatCount} || $segr->{FeatCountFixed};

	for $feat (keys %{ $segr->{Feats} }) {
	    $featv= $segr->{Feats}{$feat};
	    next if exists $featv->{Fixed};
	    o("static const BoardObject mfbo_${seg}_${feat}"."[]= {");
	    $delim=' ';
	    foreach $boob (@{ $featv->{BoObs} }) {
		o($delim);
		o(so_boob(1, $boob));
		$delim= ', ';
	    }
	    o(" };\n");
	}
	    
	o("static const MovFeatInfo mfi_${seg}"."[]= {");
	$delim='';
	for $fixedi (qw(0 1)) {
	    for $feat (keys %{ $segr->{Feats} }) {
		$featv= $segr->{Feats}{$feat};
		next if $fixedi != !!exists $featv->{Fixed};
		o("$delim\n");
		o("  { \"$feat\", mfk_".lc($featv->{Kind}).",");
		if (!$fixedi) {
		    o(" $featv->{Posns}, $featv->{Weight}, mfbo_${seg}_$feat");
		} else {
		    o(" $featv->{Fixed}, 0, 0");
		}
		o(" }");
		$delim=',';
	    }
	}
	o("\n};\n");
    }
    for $intere (@interfs) {
	map {
	    warn "warning: unused interference specification $_\n" unless m, ,;
	} @{ $intere->{Segs} };
    }

    my (@sensemap,$sensenum,$i);
    o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
    o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
    $delim= '';
    $segnum= 0;
    foreach $seg (@segs) {
	$segr= $segs{$seg};
	o("$delim\n");
	my $sensesoboob= so_objboob(1, $segr, \$sensenum);
	o(sprintf " { %-7s%d,%d,%2d,%d,%-9s%d,%-10s%-6s,%-7s",
	  "\"$seg\",",$segr->{InvBoOb}?1:0,$segr->{Inter}{Invert},
	  $segr->{FeatCount}, $segr->{FeatCountFixed},
	  ($segr->{FeatCount}||$segr->{FeatCountFixed}) ? "mfi_$seg," : '0,',
	  $segr->{Posns}, "spci_$seg,",
	  $sensesoboob,
	  so_boob(1, $segr->{InvBoOb}).',');
	$ourinter= $segr->{Inter};
	if (defined $ourinter->{Seg}) {
	    o(sprintf "%4s,0%o ", so_segnum($ourinter->{Seg}),
	      $ourinter->{Map});
	} else {
	    o(" -1 ");
	}
	o("}");
	$delim= ',';
	endmistake("sense $sensesoboob used for both".
		   " $seg and $sensemap[$sensenum]")
	    if defined $sensemap[$sensenum];
	$sensemap[$sensenum]= $seg;
	$segnum++;
    }
    o("\n};\n");
    o("const BoardObject info_maxreverse= $maxreverseobjnum;\n");
    o("#define u -1\n");
    o("const SegmentNumInMap info_segmentmap[]= {\n");
    $i=0;
    foreach $seg (@sensemap) {
	o(!$i ? ' ' :
	  !($i % 12) ? ",\n " :
	  ",");
	o(defined($seg) ? sprintf("%4s",so_segnum($seg)) : '   u');
	$i++;
    }
    o("\n};\n".
      "#undef u\n".
      "const int info_segmentmaplen= ".scalar(@sensemap).";\n");
}

# writeasm_KIND()

sub o_section ($$) {
    my ($sec,$docstring) = @_;
    o("\n;----------\n".
      "  org $sec\n");
    o($docstring);
}
sub o_section_end_fill ($$$) {
    my ($lastnumdone, $fillvalue, $entrysize) = @_;
    if ($entrysize == 1 and $lastnumdone & 1) {
	o(", $fillvalue & 0xff\n");
	$lastnumdone++;
    } else {
	o("\n");
    }
    o(sprintf "  fill %s, %d*(maxpics-%d)\n\n",
      $fillvalue, $entrysize, $lastnumdone);
}

sub o_db ($;$) {
    my ($ix,$every) = @_;
    $every=16 unless defined $every;
    o(($every ? $ix % $every : $ix) ? ',' : "\n  db ");
}

sub writeasm_sense {
    my ($num, $base);
    o_section('pic2detinfo',<<'END');
; Table indexed by pic no., giving information about sensing
; Each element is two bytes:
;  1st byte   bit 7     Set iff this board exists for the purposes of sensing
;             bits 6-3  Not used, set to zero
;             bits 2-0  Top 3 bits of sense segment numbers on this board
;  2nd byte   bit 7     Set iff this board is a Detectors board
;             bits 6-0  Base for bottom 7 bits of segment number
;                       (per-board segment no. is added to this; carry
;                        to upper 3 bits is not permitted)
END
    o("SenseExists equ 0x80\n".
      "Detectors equ 0x80\n".
      "Reversers equ 0x00\n\n");
    for ($num=0; $num<@boardtype; $num++) {
	if (!defined $boardtype[$num]) { o("  dw  0\t\t\t\t; $num\n"); next; }
	$base= $sensesbase[$num];
	o(sprintf "  db  SenseExists | 0x%02x, %12s | 0x%02x\t; %d\n",
	  $base >> 7, ucfirst($boardtype[$num]), $base & 0x7f, $num);
    }
    o_section_end_fill($num, 0, 2);
}

sub writeasm_pt ($$) { writeasm_ptwag('pt',$maxptixln2); }
sub writeasm_waggle ($$) { writeasm_ptwag('waggle',$maxwaggleixln2); }
sub writeasm_ptwag ($$) {
    my ($ptwag, $maxthingixln2) = @_;
    my $bitmapbitsperpic= 1<<$maxthingixln2;
    my $bitmapbytesperpic= 1<<($maxthingixln2-3);
    my ($num, $elemsize, $byte, $bit, $objnum);
    
    o_section("picno2${ptwag}map",<<"END");
; Bitmap indexed first by pic no, and then by thing no. on that board,
; saying whether the thing is present or not.  Each pic has
; $bitmapbytesperpic bytes, ie $bitmapbitsperpic bits.  First byte is
; objects 0 to 7, in bits 0 to 7 respectively so that MSbit of byte 3
; (4th byte) is object no.31.  Unused boards or boards with no such
; objects are all-bits-0.
END
    for ($num=0; $num<@boardtype; $num++) {
	if (!defined $boardtype[$num]) { o("  dw  0\t\t\t\t; $num"); next; }
	die if $maxthingixln2 < 4; # must be whole no. of 16-bit words
	$elemsize= $bitmapbytesperpic;
	for ($byte=0; $byte < $elemsize; $byte++) {
	    o_db($byte, 0);
	    o("b'");
	    for ($bit=7; $bit>=0; $bit--) {
		o(boob_used_bit({ Kind => $ptwag,
				  Board => $num,
				  Obj => $byte*8 + $bit }));
	    }
	    o("'");
	}
	o(" ; $num");
    }
    o("\n");
    o_section_end_fill($num, 0, $elemsize);

    my ($typeix,$type,$pi,$indexpr);
    $indexpr= '0'x(7-$maxthingixln2). 'D'. 'o'x$maxthingixln2;
    o_section("bk${ptwag}ix2portnumbitnum",<<"END");
; Table giving physical ports and pins for each $ptwag for each
; kind of board.  Index is object number (for reversers boards)
; or object number + 2^$maxthingixln2 (for detectors boards).
; Value is one byte, either 0xff meaning that board type has
; no such object, or top nybble being port number (0 for A, 1 for B,
; etc.) and bottom nybble being bit number.  Ie,
;   Index:  $indexpr    where D is 1 iff detectors board and o is obj
;   Value:  0ppp0bbb    where p is port num and b is bit num; or 0xff
END
    o("  radix hex\n");
    for ($typeix=0; $typeix<2; $typeix++) {
	$type= qw(reversers detectors)[$typeix];
	die $type unless $pin_info{$type};
	o("; $type:");
	for ($objnum=0; $objnum < (1 << $maxthingixln2); $objnum++) {
	    o_db($objnum);
	    $pi= $pin_info{$type}{kind2genkind($ptwag)}[$objnum];
	    if (defined $pi) {
		$pi =~ m/^(\d)\,(\d)\,/ or die;
		o($1.$2);
	    } else {
		o('ff');
	    }
	}
	o("\n");
    }
    o("  radix dec\n\n");
}

sub writeasm_reverse {
    my ($num,$kc,$bit, @portae,$pu);
    o_section('picno2revmasks',<<END);
; Table listing which reversers are connected/enabled.  Index is pic
; number.  Each entry is 2 bytes: mask for port A followed by mask for
; port E.  A 1 bit is a connected reverser.  Both masks are 0 for
; non-reversers boards.
END
    for ($num=0; $num<@boardtype; $num++) {
	@portae= ([],[]);
	$kc= $kind_count{$boardtype[$num]}{'reverse'};
	for ($bit= $kc-1; $bit>=0; $bit--) {
	    $pu= boob_used({ Board => $num,
			     Obj => $bit,
			     Kind => 'reverse' });
	    next unless $pu;
	    $pu->[1] =~ m/^([04])\,\d,(0x\w{2})$/ or die;
	    push @{ $portae[!!$1] }, $2;
	}
	o('  db ');
	o(join(', ', map { @$_ ? join('|',@$_) : '0' } @portae));
	o(sprintf " ; %d\n",$num);
    }
    o_section_end_fill($num, '0x0000', 2);
}

sub writeasm () {
    my ($k,$w,$i,@d,$or,$p,$portnum,$bit,$each);
    close STDOUT or die $!;
    open STDOUT, ">$basename+pindata.asm" or die $!;
    o("; autogenerated - do not edit\n");
    o("  include pindata.inc\n".
      "  radix dec\n".
      "ff equ 0xff\n");
    $each= 10;
    for $k (@objkinds) {
	&{"writeasm_$k"}();
    }
    o("\n  end\n");
}

sub writeforui () {
    close STDOUT or die $!;
    open STDOUT, ">$basename.dgram.segmap-info" or die $!;
    o("# autogenerated - do not edit\n");
    foreach my $seg (keys %segs) {
	my $segr= $segs{$seg};
	my $featmap= $segr->{FeatMap};
	next unless $featmap;
	foreach my $mapent (@$featmap) {
	    o("layout-subseg-featmap $seg $mapent->{Abstract}");
	    local ($_) = $mapent->{Concrete};
	    s/([A-Z]+)(\d+)/  o(" $1 $2"); "";  /ge;
	    die "$seg $_ ?" if length;
	    o("\n");
	}
    }
}

mainread();
redaction();
writeout();
writeasm();
writeforui();
movfeatposmap_checks();
exit 1 if $mistakes;