#!/usr/bin/perl -w
#
# Copyright (c) 2000 Anoop Sarkar
#

my $rcsid = '$Id: corpus2forest.pl,v 1.2 2001-05-09 01:28:57 anoop Exp $'; #'

## default values for options
my $grammar_file  = 'grammar.pl';
my $verbose  = 0;

my $progname = $0; $progname =~ s|.*/||;
my $usage = <<EOU;
$progname [-v] [-g=file] [-e=file] filename

-v          verbose setting  [default: $verbose]
-g=file     grammar filename [default: $grammar_file]
filename    corpus file (one word and attachment per line)

EOU

my $ERROR    = 0;
my $LEFTAUX  = 1;
my $RIGHTAUX = 2;
my $IS_FOOT  = 3;
my $SUBST    = 4;

my $ROOT     = 'root';
my $PUNCT    = '-';
my $TOP      = '**TOP**';
my $INSERTED = '@';

my %treenode_memo = ();
my %auxtree_memo  = ();
my %headp_memo    = ();

my %ispunct   = ();
my %start     = ();
my %attachtbl = ();
my %wordtbl   = ();
my %treetbl   = ();

if ($#ARGV < 0) { die $usage; }

while ($ARGV[0] =~ /^-/) {
    $verbose  = 1  if ($ARGV[0] =~ /^-v$/);
    $grammar_file  = $1 if ($ARGV[0] =~ /^-g=(.*)$/);
    shift(@ARGV); 
}

print STDERR "using verbose=$verbose\n";
print STDERR "using grammar=$grammar_file\n";

my $filename = shift(@ARGV) or die $usage;

my ($user1,$system1,$cuser1,$csystem1) = times;

@label          = ();
@lchild         = ();
@rchild         = ();
@tree           = ();
@rootnode       = ();
@footp          = ();
#@substp        = ();
@headp          = ();
#@NA            = ();
%treename       = ();
#$num_trees     = 0;
#$num_treenodes = 0;

if (-f $grammar_file) { require $grammar_file; }
else { die "could not find $grammar_file\n"; }

my ($user2,$system2,$cuser2,$csystem2) = times;
print STDERR "time taken to read grammar:",
    " user=",    $user2-$user1, 
    " system=",  $system2-$system1, "\n";


sub find_children
{   my ($node) = @_;
    my @children = ();

    if (!defined $node) { return(); }

    if (!defined $label[$node]) {
	print STDERR "unknown node: $node\n";
    } else {
	push(@children, is_inserted($lchild[$node]));
	push(@children, is_inserted($rchild[$node]));
    }
    return(@children);
}

sub is_inserted
{   my ($node) = @_;
    my @children = ();

    if (!defined $node) { return (); }

    if ($label[$node] eq $INSERTED) {
	push(@children, is_inserted($lchild[$node]));
	push(@children, is_inserted($rchild[$node]));
    } else {
	push(@children, $node);
    }
    return(@children);
}

sub find_treenode
{   my ($t, $gornaddr) = @_;

    # check if previously computed
    if (defined $treenode_memo{$t}{$gornaddr}) {
	print STDERR "previous: treename=$t; gorn=$gornaddr\n" 
	    if ($verbose);
	return($treenode_memo{$t}{$gornaddr});
    }

    my $root = $rootnode[$treename{$t}];

    if ($gornaddr eq $ROOT) {
	return($root);
    }

    my $curnode = $root;
    my @gornlist = split('_', $gornaddr);
    my $i;
    my $sz = $#gornlist + 1;
    my @children;

    for ($i = 0; $i < $sz; $i++)
    {
	@children = find_children($curnode);
	if (!defined $children[$gornlist[$i]]) {
	    die "could not resolve $gornaddr in tree: $t\n";
	}
	$curnode = $children[$gornlist[$i]];
    }

    # store answer in memo table 
    $treenode_memo{$t}{$gornaddr} = $curnode;
    print STDERR "tree=$t; gorn=$gornaddr; treenode=$curnode\n" 
	if ($verbose);

    return($curnode);
}

sub is_auxtree
{   my ($tree) = @_;
    return (defined $footp[$tree]);
}

sub auxtree_type
{   my ($tree, $root) = @_;

    if (defined $auxtree_memo{$tree}) {
	return $auxtree_memo{$tree};
    }

    my $type = auxtree_traverse($tree, $root);

    if ($type == $ERROR) { 
	die "Error: auxtree_type: tree=$tree\n";
    }

    $auxtree_memo{$tree} = $type;
    return $type;
}

sub auxtree_traverse
{   my ($tree, $node) = @_;    
    if (!defined $node) { return 0; }
    if ($footp[$tree] == $node) { 
	return $IS_FOOT; 
    } else {
	my $left  = auxtree_traverse($tree, $lchild[$node]);
	my $right = auxtree_traverse($tree, $rchild[$node]);
	return $RIGHTAUX  if ($left  == $IS_FOOT);
	return $LEFTAUX   if ($right == $IS_FOOT);
	return ($left or $right or $ERROR);
    }
}

my @treelabel  = ();
my %derivation = ();
my @sentence   = ();

foreach $t (keys %treename)
{
    $treelabel[$treename{$t}] = $t;
}

my $counter = 0;
sub dump_tree
{   my ($root, $windex) = @_;

    if (!defined $root) { return($counter); }

    my $treeindex = $tree[$root];
    my $treelabel = $treelabel[$treeindex];
    my $treeroot  = $rootnode[$treeindex];
    my $treefoot  = -1;
    $treefoot = $footp[$treeindex] if (defined $footp[$treeindex]);

    my $nodetype = '';
    my $nodelbl  = '';
    if ($treeroot == $root) {
	$nodetype  = is_auxtree($treeindex) ? "<auxroot>" : "<initroot>";
    } else {
	$nodetype = "<internal>";
    }

    if (is_auxtree($treeindex)) {
	$nodelbl = '<' . $treeroot . '-' . $label[$treeroot] . '/' . $treefoot . '-' . $label[$treefoot] . '>';
    } else {
	$nodelbl = '<' . $treeroot . '-' . $label[$treeroot] . '/>';
    }

    if (!defined $sentence[$windex]) {
	die "Error: invalid index: $windex for node: $root\n";
    }
    my $header = "%d: $treelabel" . "[" . $sentence[$windex] . "]<" . $root . '-' . $label[$root] . "/%s><->%s" . $nodelbl . "[%s] %s\n";

    my $modifchild = -1;
    my $adjoin = 0;
    my $modiftype = $ERROR;
    if (defined $derivation{$root}{$windex}) {
	my ($newroot, $newindex) = split(' ', $derivation{$root}{$windex});
	$counter = dump_tree(int($newroot), int($newindex));
	$modifchild = $counter;
	$adjoin = 1;
	my $adjtree = $tree[int($newroot)];
	if (is_auxtree($adjtree)) { $modiftype = auxtree_type($adjtree, int($newroot)); }
	else { $modiftype = $SUBST; }
    } else {
	$adjoin = 0;
    }

    my $lchild = $lchild[$root];
    my $rchild = $rchild[$root];

    if (!defined $lchild) { 
	if ($root == $treefoot) { 
	    printf $header, ++$counter, 'bot', '<auxfoot>', '<>', '';
	} else {
	    printf $header, ++$counter, 'bot', '<internal>', '<>', '';
	}
    } elsif (!defined $rchild) {
	my $lc = dump_tree($lchild, $windex);
	printf $header, ++$counter, 'bot',  '<internal>', '', "[$lc,(nil)]";
    } else {
	my $lc = dump_tree($lchild, $windex);
	my $rc = dump_tree($rchild, $windex);
	printf $header, ++$counter, 'bot', '<internal>', '', "[$lc,$rc]";
    }

    my $child = $counter;
    if ($adjoin) {
	if ($modiftype == $LEFTAUX) {
	    printf $header, ++$counter, 'top', $nodetype, '', "[$modifchild,$child]";
	} elsif ($modiftype == $RIGHTAUX) {
	    printf $header, ++$counter, 'top', $nodetype, '', "[$child,$modifchild]";
	} else 	{
	    printf $header, ++$counter, 'top', $nodetype, '', "[$modifchild,$child]";
	}    
    } else {
	printf $header, ++$counter, 'top', $nodetype, '', "[$child,(nil)]";
    }

    return($counter);
}

sub dump_derivation
{
    if ($#sentence < 0) { return; }
    print "begin sent=\"" . join(' ', @sentence) . "\"\n";
    my ($root, $windex) = split(' ', $derivation{$TOP}{-1});
    $counter = 0;
    $counter = dump_tree(int($root), int($windex));
    print "start: $counter []\n";
    print "end\n";
}

($user1,$system1,$cuser1,$csystem1) = times;

my $ln = 0;
open (T, $filename) or die "could not open $filename\n";
while (<T>) {

    chomp;
    $ln++;
    next if (/^\s*$/);

    my @line = split;

    my $windex   = $line[0];
    my $depindex = $line[7];

    if ($windex eq '0') {
	dump_derivation();
	%derivation = ();
	@sentence   = ();
    }

    # word, treename adjoins/substitutes into depword, deptree at
    # gornaddr (in deptreename)

    my $word         = $line[1];
    my $POS          = $line[2];
    my $treename     = $line[3];

    push(@sentence, $word);

    if ($treename eq $PUNCT) {
	$ispunct{$word} = 1;
	next;
    }

    my $anchor       = $line[4];
    my $gornaddr     = $line[6];
    my $depword      = $line[8];
    my $depPOS       = $line[9];
    my $deptreename  = $line[10];

    # pick only the tree_number as the name of the tree (see etrees.y)
    my $t = $treename;
    $t =~ s/^.*=(\d+)_.*$/$1/;
    my $tree = $treename{$t};

    my $d = $deptreename;
    $d =~ s/^.*=(\d+)_.*$/$1/;
    my $deptree = $treename{$d};

    my $root = $rootnode[$tree];

    $wordtbl{"$word $headp[$tree]"} = 1;
    $treetbl{$tree} = 1;

    # root of the derivation
    if ($depword eq $TOP) {
	$start{$root} = 1;
	if (defined $derivation{$TOP}{-1}) { 
	    die "Error: duplicate TOP node at line $ln\n"; 
	} 
	$derivation{$TOP}{-1} = "$root $windex";
	next;
    }

    my $treenode = find_treenode($deptree, $gornaddr);

    if (defined $derivation{$treenode}{$depindex}) { 
	die "Error: duplicate node: $treenode and index: $windex at line $ln\n"; 
    } 
    $derivation{$treenode}{$depindex} = "$root $windex";

    print STDERR "$word, $POS, $tree, $treenode, $depword, $depPOS, $deptree\n" 
	if ($verbose);
}
dump_derivation();
close(T);

($user2,$system2,$cuser2,$csystem2) = times;

print STDERR "time taken to process corpus:",
    " user=",    $user2-$user1, 
    " system=",  $system2-$system1, "\n";