#!/usr/bin/perl -w

use strict qw(vars);

our ($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}{Ends}[$combpos][$end] = [ $node,$side ]

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

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

sub line_barf () { die; }

sub begin_points () { }
sub line_points () {
    my ($seg,$pt,@boob,$bodef);
    m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or die "$_ ?";
    ($seg,$pt,$boob[0],$bodef,$boob[1])=($1,$2,$3,$4,$5);
    $boob[1] =~ s/^\./$bodef./;
    die "$_ ?" unless exists $segs{$seg};
    die "$_ ?" if exists $segs{$seg}{Feats}{$pt};
    $segs{$seg}{Feats}{$pt}= {
	Kind => Point,
	Weight => $segs{$seg}{Posns},
	Posns => 2,
	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 die "$_ ?";
    ($seg,$pt,$pos)=($1,$2,$3);
    die "$_ ?" unless exists $segs{$seg};
    die "$_ ?" 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 die "$_ ?";
    ($seg,$boob)=($1,$2);
    die "$_ ?" if exists $segs{$seg};
    $segs{$seg}= {
	BoOb => $boob,
	Inv => $invertible,
	Posns => 1,
	Feats => { },
	FeatCount => 0
    };
}

sub begin_endwiring () {
}

#	o("static const SegPosCombInfo spci_${seg}[]= {");
#	$delim='';
#	for ($comb=0; $comb < $segv->{Posns}; $comb++) {
#	}

sub mistake ($) {
    my ($m) = @_;
    die "mistake: $m\n in \`$currentline'\n";
}

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 die "$_ ?";
    ($ns[0],$ns[1],$seg,$subspec,$dist)=($1,$2,$3,$4,$5);
    if (!exists $segs{$seg}) {
	print STDERR "ditching unwired $seg$subspec\n";
	return;
    }
    $segr= $segs{$seg};
    @subsegil= defined $subspec ? $subspec =~ m/([A-Za-z]+)(\d+)/g : ();
    while (@subsegil) {
	($feat,$pos,@subsegil) = @subsegil;
	mistake("no wiring for $seg/$feat")
	    unless exists $segr->{Feats}{$feat};
	$featr= $segr->{Feats}{$feat};
	if (exists $featr->{Fixed}) {
	    if ($pos != $featr->{Fixed}) {
		print STDERR "ditching fixed-elsewise $seg$subspec\n";
		return;
	    }
	} else {
	    die "$pos $featr->{Posns} ?" unless $pos < $featr->{Posns};
	    $featposwant{$feat}= $pos;
	}
    }
    $combpos= 0;
    for $feat (keys %{ $segr->{Feats} }) {
	$featr= $segr->{Feats}{$feat};
	next if exists $featr->{Fixed};
	die "$feat ?" if !exists $featposwant{$feat};
	$combpos += $featposwant{$feat} * $featr->{Weight};
    }
    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}) {
	    $nsr->{Seg}= $seg;
	} elsif ($seg ne $nsr->{Seg}) {
	    die "$seg $nsr->{Seg} ?";
	}
	$endposr= $segr->{Ends}[$combpos];
	die "$seg $combpos ?" if defined $endposr && @$endposr;
	$endposr->[$end]= [ $node, $side ];
    }
}

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

sub so_oboob ($) {
    my ($obj) = @_;
    my ($boob);
    $boob= $obj->{BoOb};
    $boob =~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/ or die "$boob ?";
    return sprintf "%d,%2d",$1,$2;
}

sub mainread () {
    while (<>) {
	next if m/^\#/;
	chomp;
	s/\s+$//;
	next unless m/\S/;
	last if m/^end$/;
	if (m/^(invertible|vanilla|points|fixed|endwiring)$/) {
	    $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);
    o("/* autogenerated - do not edit */\n\n".
      "#include \"safety.h\"\n\n");
    @segs=();
    for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
	$segs{$seg}{Num}= @segs;
	push @segs, $seg;
    }
    foreach $seg (@segs) {
	$segr= $segs{$seg};
	next unless $segr->{FeatCount};
	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\", $ptv->{Posns}, $ptv->{Weight} }");
	    $delim=',';
	}
	o("\n};\n");
    }
    o("static const SegmentInfo info_segments[".scalar(@segs)."]= {");
    $delim= '';
    foreach $seg (@segs) {
	$segr= $segs{$seg};
	o("$delim\n");
	o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-9s %-6s }",
	  "\"$seg\",", $segr->{Inv},
	  $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
	  $segr->{Posns}, ($segr->{FeatCount} ? "pci_$seg," : '0,'),
	  so_oboob($segr));
	$delim= ',';
    }
    o("\n};\n");
}

mainread();
writeout();