#!/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);
# $segs{$seg}{Inv}
# $segs{$seg}{BoOb}
# $segs{$seg}{Posns}
# $segs{$seg}{FeatCount}              does not include Fixed
# $segs{$seg}{Feats}{$pt}{Kind}       Point or Fixed
# $segs{$seg}{Feats}{$pt}{Weight}     ) for Point only
# $segs{$seg}{Feats}{$pt}{Posns}      ) for Point only
# $segs{$seg}{Feats}{$pt}{BoOb}[]     ) for Point only
# $segs{$seg}{Feats}{$pt}{Fixed}      position, for Fixed only

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

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

our ($nextboardnum,@boardtype,%numboards,$nreverses,@sensesin,@sensesbase);
# @boardtype[$boardnum]
# $numboards{$type}
# $nreverses
# $sensesin[$page]
# $sensesbase[$boardnum]= ($page << 7) | $baselsbyte
$nextboardnum= 0;
$nreverses= 0;
$sensesin[0]= 0;
@objkinds= qw(pt sense reverse);

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

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

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 "ditching $m\n";
}

sub begin_points () { }
sub line_points () {
    my ($seg,$pt,@boob,$bodef);
    m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
	return syntaxerror();
    ($seg,$pt,$boob[0],$bodef,$boob[1])=($1,$2,$3,$4,$5);
    $boob[1] =~ s/^\./$bodef./;
    mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
    mistake("duplicate wiring for $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
    $segs{$seg}{Feats}{$pt}= {
	Kind => Point,
	Weight => $segs{$seg}{Posns},
	Posns => 2,
	BoOb => [ map { pa_boob($_) } @boob ]
	};
    $segs{$seg}{Posns} *= 2;
    $segs{$seg}{FeatCount}++;
}

sub begin_fixed () { }
sub line_fixed () {
    my ($seg,$pt,$pos);
    m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
    ($seg,$pt,$pos)=($1,$2,$3);
    mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
    mistake("duplicate fixed $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
    $segs{$seg}{Feats}{$pt}= {
	Kind => Fixed,
	Fixed => $pos
	};
}

sub begin_segment () { }
sub line_segment () {
    my ($seg,$boob);
    m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
    ($seg,$boob)=($1,$2);
    mistake("duplicate topology for $seg") if exists $segs{$seg};
    $segs{$seg}= {
	BoOb => pa_boob($boob),
	Inv => $invertible,
	Posns => 1,
	Feats => { },
	FeatCount => 0
    };
}

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;
    $numboards{$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_board_$type"}($num);
}

sub line_board_reversers ($) {
    my ($num) = @_;
    my ($i,$objnum);
    for ($i=0; $i<5; $i++) {
	$objnum= so_boob('reverse', [ $num,$i ]);
	$nreverses= $objnum+1 if $objnum >= $nreverses;
    }
}

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

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$subspec");
	return;
    }
    $segr= $segs{$seg};
    @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 $seg$subspec");
		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 $seg/$subspec")
	    if !exists $featposwant{$feat};
	$combpos += $featposwant{$feat} * $featr->{Weight};
    }
    mistake("duplicate topology for $seg/$subspec")
	if defined $segs{$seg}{Dist}[$combpos];
    $segs{$seg}{Dist}[$combpos]= $dist;
    $endposr= $segr->{Ends}[$combpos];
    die "$seg $combpos @$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 ($boob) = @_;
    if ($boob !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
	mistake("invalid board object $boob");
	return [ 0,0 ];
    }
    return [ $1,$2 ];
}

# so_boob_KIND($boardnum,$objnum,$boardtype,$pininfo) -> global object number

sub so_boob_pt {
    my ($boardnum,$obj)=@_;
    mistake("point encoding out of range") if $boardnum>31;
    die if $obj > 31;
    return ($boardnum << 5) | $obj;
}

sub so_boob_reverse {
    my ($boardnum,$obj,$boardtype)=@_;

    # Converts board and object number (in canonical pic number plus
    # and reverse0...reverse5 as seen on pinout diagrams), to
    # object 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_do_here)
    #
    #  * We figure out which bit of which message byte the
    #    object corresponds to.  (see reverse.asm, polarity_decode_message)
    #
    #  * We compute the README.protocol bit and byte number.
    
    my ($cycle,$boardincycle,$cyclebasebyte,$byte,$bit);
    die unless $boardtype eq 'reversers';
    die if $obj > 5;
    $obj = sprintf '%d', $obj;
    $obj =~ y/302154/543210/; # mapping due to polarity_do_here
    $cycle= int(($boardnum+3) / 7);
    $boardincycle= ($boardnum+3) - $cycle*7;
    $cyclebasebyte= $cycle*6 - 2;
    if ($boardnum==2 && $obj > 2) {
	$byte= 0; $bit= $obj-3;
	return 3 - $bit; # only these three in byte 0, a special case
    } elsif ($boardincycle<5) {
	$byte= $cyclebasebyte + $boardincycle; $bit= $obj;
    } elsif ($boardincycle==6) {
	$byte= $cyclebasebyte + 5; $bit= $obj;
    } elsif ($boardincycle==5) {
	$byte= $cyclebasebyte + 5 - $bit; $bit= 6;
    } else {
	die;
    }
    return $byte*7 + 3 - $bit;
}

sub so_boob_sense($$$) {
    my ($boardnum,$obj)=@_;
    my ($inpage);
    $inpage= $obj + $sensesbase[$boardnum];
    die if $inpage > 127;
    return ($boardnum << 7) | $inpage;
}    

sub so_boob ($$) {
    my ($kind,$bo) = @_;
    if (defined $bo) {
	my ($board,$obj)= @$bo;
	my ($objnum,$type,$pi);
	mistake("unknown board number $board")
	    unless defined $boardtype[$board];
	$type= $boardtype[$board];
	$pi= $pin_info{$type}{$kind};
	mistake("object reference $kind $board.$obj out of range for".
		" board type $type")
	    unless defined $pi->[$obj];
	$objnum= &{"so_boob_$kind"}($board,$obj,$type,$pi);
	$pin_used{$kind}[$objnum]= [ $board, $pi->[$obj], $obj ];
	return sprintf("%4d /* %d.%-2d*/", $objnum, $board, $obj);
    } else {
	return "   0 /*none*/ ";
    }
}

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

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

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

sub writeout () {
    my (@segs,$segn,$seg,$segr,$pt,$ptv, $delim);
    my ($comb,$pi,$feat,$featr,$end,$boob);
    my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
    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_TRAINS 1000000\n".
      "#define NUM_SEGMENTS %s\n\n".
      "#include \"layout-data.h\"\n\n",
      scalar @segs);
    foreach $seg (@segs) {
	$segr= $segs{$seg};

	o("static const SegPosCombInfo spci_${seg}"."[]= {");
	$delim='';
	for ($comb=0; $comb < $segr->{Posns}; $comb++) {
	    $pi='';
	    foreach $feat (keys %{ $segr->{Feats} }) {
		$featr= $segr->{Feats}{$feat};
		next if exists $featr->{Fixed};
		$pi.= sprintf("%s%d", $feat,
			      ($comb / $featr->{Weight}) % $featr->{Posns});
	    }
	    o("$delim\n");
	    o(sprintf "  { %-8s %4d",
	      '"'.$seg.(length $pi ? '/' : '').$pi.'",',
	      $segr->{Dist}[$comb]);
	    for ($end=0; $end<2; $end++) {
		o(", { ");
		$otherend= $segr->{Ends}[$comb][$end];
		defined $otherend or die "$seg $comb $end ?";
		($node,$side) = @$otherend;
		$nodeotherside= $nodes{$node}[1-$side];
		if (defined $nodeotherside) {
		    $otherseg= $nodeotherside->{Seg};
		    $otherbackrelus= $nodeotherside->{End} ^ $end ^ 1;
		    o(sprintf "/*%5s.%d %-5s*/ %d,%3d",
		      $node,$side,
		      ($otherbackrelus?'-':' ').$otherseg,
		      $otherbackrelus,
		      $segs{$otherseg}{Num});
		} else {
		    o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
		      $node,$side);
		}
		o(" }");
	    }
	    o(sprintf " }");
	    $delim= ',';
	}
	o("\n};\n");

	next unless $segr->{FeatCount};

	for $pt (keys %{ $segr->{Feats} }) {
	    $ptv= $segr->{Feats}{$pt};
	    next if exists $ptv->{Fixed};
	    o("static const BoardObject mfbo_${seg}_${pt}"."[]= {");
	    $delim=' ';
	    foreach $boob (@{ $ptv->{BoOb} }) {
		o($delim);
		o(so_boob('pt',$boob));
		$delim= ', ';
	    }
	    o(" };\n");
	}
	    
	o("static const MovFeatInfo mfi_${seg}"."[]= {");
	$delim='';
	for $pt (keys %{ $segr->{Feats} }) {
	    $ptv= $segr->{Feats}{$pt};
	    next if exists $ptv->{Fixed};
	    o("$delim\n");
	    o("  { \"$seg/$pt\", mfk_".lc($ptv->{Kind}).",".
	      " $ptv->{Posns}, $ptv->{Weight}, mfbo_${seg}_$pt }");
	    $delim=',';
	}
	o("\n};\n");
    }
    o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
    o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
    $delim= '';
    foreach $seg (@segs) {
	$segr= $segs{$seg};
	o("$delim\n");
	o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-10s %-6s,%-6s }",
	  "\"$seg\",", $segr->{Inv},
	  $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
	  $segr->{Posns}, "spci_$seg,",
	  so_oboob('sense',$segr),
	  so_oboob('reverse', $segr->{Inv} ? $segr : undef));
	$delim= ',';
    }
    o("\n};\n");
}

# writeasm_KIND()

sub o_section ($) {
    my ($sec) = @_;
    o("$sec code ${sec}_start");
}

sub writeasm_sense {
    o_section("pindata_pic2detinfo");
    o("Exists equ 0x8000\n".
      "Detectors equ 0x0080\n".
      "Reversers equ 0x0000\n");
    for ($num=0; $num<@boardtype; $num++) {
	if (!defined $boardtype[$num]) { o(" dw  0\n"); next; }
	$base= $sensesbase[$num];
	o(sprintf " dw  Exists | %-10s | 0x%02x%02x\n",
	  ucfirst($boardtype[$num]), $base >> 7, $base & 0x7f);
    }
    o(sprintf " fill 0, maxboards_count-%d\n", $num);
    o("\n");
}

# 	for $w (qw(pic port bit)) {
# 	    @d=();
# 	    o("\n");
# 	    o("${k}_${w}_data_section  org  ${k}_${w}_data\n");
# 	    for ($i=0; $i<@{ $pin_used{$k} }; $i++) {
# 		$or= $pin_used{$k}[$i];
# 		if (defined $or) {
# 		    $or->[1] =~ m/^(\d+)\,\d+,(\w+)$/;
# 		    ($portnum,$bit)= ($1,$2);
# 		    $portnum= sprintf "%02x", $portnum + 0x89; # 89=LATA
# 		    $bit= sprintf "%02x", hex $bit;
# 		} else {
# 		    $portnum=$bit='00';
# 		}
# 		if ($w eq 'pic') {
# 		    if (defined $or) {
# 			push @d, $or->[0];
# 		    } else {
# 			push @d, 'X',
# 		    }
# 		} elsif ($w eq 'port') {
# 		    push @d, $portnum;
# 		} elsif ($w eq 'bit') {
# 		    push @d, $bit;
# 		} else {
# 		    die;
# 		}
# 	    }
# 	    push @d, 'X' if @d^1;
# 	    @d= map { s/^[a-f]/0$&/; sprintf "%3s", $_ } @d;
# 	    for (;;) {
# 		$d[$each/2] = " $d[$each/2]" if $#d >= $each/2;
# 		last if @d <= $each;
# 		o("        db      ". join(',',@d[0..($each-1)]). "\n");
# 		@d= @d[$each..$#d];
# 	    }
# 	    o("        db      ".join(',',@d)."\n");
# 	    if ($w eq 'pic') {
# 		o("        if \$ > ${k}_pic_data + ${k}_num_max\n".
# 		  "         error \"too much ${k}_picdata\"\n".
# 		  "        endif\n".
# 		  "        fill 0xffff, ${k}_pic_data + ${k}_num_max - \$\n");
# 	    }
# 	}
#     }
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".
      "X       equ 0xff\n");
    $each= 10;
    for $k (@objkinds) {
	&{"writeasm_$k"}();
    }
    o("\n        end\n");
}
mainread();
writeout();
writeasm();