#!/usr/bin/env perl
# Copyright (C) 1997-2005 The CDG Team <cdg@nats.informatik.uni-hamburg.de>
#
# This file is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version. For
# more details read COPYING in the root of this distribution.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# translate wsj sexpression format to negra export format
#
# author: Michael Daum <micha@nats.informatik.uni-hamburg.de>
# initial revision: 2003-09-24

use warnings;
use strict;
use Parse::RecDescent;

our $nrSentences = 1;

#------------------------------------------------------------------------------
sub main {
   print "%%  automatically generated by penn2negra.pl (c) 2003 \n" .
         '%% $Id: penn2negra.pl,v 1.4 2006-03-13 17:49:05 micha Exp $' . "\n" .
         '%% contact: The CDG Team <cdg@nats.informatik.uni-hamburg.de>' . "\n\n";


my $pennGrammar = <<'EOG';
{
   my $debug = 0;
   my $maxId = 0;
   my $innerMaxId = 500;
   my $posTagPattern;

   # penn tag set
   $posTagPattern = q{(?:
     \#|\$|(?:'')|,|(?:-LRB-)|(?:-RRB-)|\.|:|(?:``)|(?:\bWP\$?)|(?:\bPRP\$)|
     \b(?:(?:CC)|(?:CD)|(?:DT)|(?:EX)|(?:FW)|(?:IN)|(?:JJ)|(?:JJR)|(?:JJS)|
     (?:LS)|(?:MD)|(?:NN)|(?:NNP)|(?:NNPS)|(?:NNS)|(?:PDT)|(?:POS)|(?:PRP)|
     (?:RB)|(?:RBR)|(?:RBS)|(?:RP)|(?:SYM)|(?:TO)|(?:UH)|(?:VB)|(?:VBD)|
     (?:VBG)|(?:VBN)|(?:VBP)|(?:VBZ)|(?:WDT)|(?:WRB))\b)};

   # stts
   # TODO: extend me
   $posTagPattern = q{(?:\b(?:PWS|VMFIN|VVFIN|PPER)\b|\$\.)};

   my $nodeTagPattern = q{[A-Z\|]+};
   my $edgeTagPattern = q{(?:(?:--)|[A-Z]+)};
   my %nodes;	# map node ids to nodes
   my %references; # map trace references to nodes

   #my $secEdgeTagPattern = q{
   #(?:\*)|(?:\*EXP\*)|(?:\*ICH\*)|(?:\*PPA\*)|
   #(?:\*RNR\*)|(?:\*T\*)|(?:0)};
   #
}

sentence: { print STDERR "DEBUG: trying sentence at\n'$text'\n" if $debug; } <reject>
sentence: '(' sExpr ')'
   {
     print STDERR "DEBUG: found sentence\n" if $debug;
     my $rootNode = {
       "id" => -1,
       "isLexHead" => 1,
       "nodeTag" => "ROOT",
       "edgeTag" => "ROOT",
       "word" => "NIL",
       "children" => [$item[2]],
     };

     # establish traces and coreferences
     foreach my $nodeId (keys %nodes) {
       my $node = $nodes{$nodeId};
       if(defined $node->{traceId}) {
 	my $reference = $references{$node->{traceId}};
   	$node->{trace} = $reference;
 	$reference->{backTrace} = $node;
       }
       if(defined $node->{corefId}) {
 	my $reference = $references{$node->{corefId}};
   	$node->{coref} = $reference;
 	$reference->{backRef} = $node;
       }
     }
     # process one sentence
     $return = &::processSentence($rootNode, \%nodes);
     undef %nodes;
     undef %references;
     $maxId = 0;
     $innerMaxId = 500;
   } | {
     print STDERR "ERROR: in $::nrSentences. sentence\n$text\n";
     $return = -1;
   }

sExpr: { print STDERR "DEBUG: trying sExpr at\n$text\n" if $debug; } <reject>
sExpr: '(' sExprContent ')'
   {
     print STDERR "DEBUG: found sExpr\n" if $debug;
     $return = $item[2];
   }

sExprContent: { print STDERR "DEBUG: trying sExprContent at\n$text\n" if $debug; } <reject>
sExprContent:
   nodeTag sExpr(s)
   {
     my $nodeTag = $item[1][0];
     my $edgeTag = $item[1][1];
     my $ref1Id = $item[1][2];
     my $ref2Id = $item[1][3];
     my $node = {
       "nodeTag" => $nodeTag,
       "edgeTag" => $edgeTag?$edgeTag:"--",
       "id" => $innerMaxId++,
       "children" => $item[2],
     };
     $nodes{$node->{id}} = $node;

     if (defined $ref1Id) {
       $node->{corefId} = $ref1Id;
     }
     if (defined $ref2Id) {
       $references{$ref2Id} = $node;
     }
     foreach my $child (@{$node->{children}}) {
       $child->{parent} = $node;
     }
     $return = $node;
   }
   | posTag /([^()\s]+)/
   {
     my $nodeTag = $item[1][0];
     my $edgeTags = $item[1][1];
     if ($edgeTags ne '') {
       $edgeTags =~ s/^-//;
     } else {
       $edgeTags = '--';
     }
     my $node = {
       "nodeTag" => $nodeTag,
       "edgeTag" => $edgeTags,
       "id" => $maxId++,
       "word" => $item[2],
     };
     $nodes{$node->{id}} = $node;
     $return = $node;
   }
   | emptyCat
   {
     my $node = {
       "word" => $item[1][0],
       "edgeTag" => "--",
       "nodeTag" => "-NONE-",
       "id" => $maxId++,
     };
     if ($item[1][1]) {
       $node->{traceId} = $item[1][1];
     }
     $nodes{$node->{id}} = $node;
     $return = $node;
   }

emptyCat: { print STDERR "DEBUG: trying emptyCat at\n$text\n" if $debug; } <reject>
emptyCat:
   '-NONE-' /0|(\*\?\*)/
   {
     $return = [$item[2]];
   }
   |
   '-NONE-' /(\*(?:[A-Z]+\*)?)(?:\-([0-9]+))?/
   {
     $return = [$1, $2];
   }
   | <error: error parsing emptyCat near\n$text>

nodeTag: { print STDERR "DEBUG: trying nodeTag at\n$text\n" if $debug; } <reject>
nodeTag: /($nodeTagPattern)((?:-$edgeTagPattern)*)(?:=([0-9]+))?(?:-([0-9]+))?/
   {
     my $nodeTag = $1;
     my $edgeTags = $2;
     my $ref1Id = $3;
     my $ref2Id = $4;
     if ($edgeTags) {
       $edgeTags =~ s/^-//;
     }
     $return = [$nodeTag, $edgeTags, $ref1Id, $ref2Id];
   }
   | <error: error parsing an nodeTag near\n$text>

posTag: { print STDERR "DEBUG: trying posTag at \n$text\n" if $debug; } <reject>
posTag: /($posTagPattern)((?:-$edgeTagPattern)*)/x
   {
     my $posTag = $1;
     my $edgeTag = $2 || '';
     print STDERR "DEBUG: found posTag = $posTag, edgeTag=$edgeTag\n" if $debug;
     $return = [$posTag, $edgeTag];
   }
   | <error: error parsing a posTag near\n$text>


EOG

   my $parser = Parse::RecDescent->new($pennGrammar)
     or die "ERROR: bad treebank parser\n";

   # call processSentence for each sentence
   undef $/;
   while (my $data = <>) {
     my $retval = $parser->sentence(\$data);
     die "\n" if $retval == -1;
     last if $retval == 0;
   }
   $/ = "\n";
}

#------------------------------------------------------------------------------
sub processSentence {
   my $rootNode = shift;
   my $nodes = shift;

   print STDERR "s$nrSentences     \r";
   print "#BOS $nrSentences 1 20030916 1\n";

   foreach my $id (sort { $a <=> $b } keys %{$nodes}) {
     my $node = $nodes->{$id};
     my $word = $node->{word};
     my $nodeTag = $node->{nodeTag};
     my $edgeTag = $node->{edgeTag};
     my $parentNode = $node->{parent};
     my $parentId = $parentNode->{id} || "0";
     my $traceNode = $node->{trace};
     my $corefNode = $node->{coref};

     if (defined $word) {
       printf "%-20s ", $word;
     } else {
       printf "#%d ", $id;
     }
     printf "%-5s -- %-5s %-5s", $nodeTag, $edgeTag, $parentId;

     if ($traceNode) {
       print "TRACE $traceNode->{id}";
     }
     if ($corefNode) {
       print "COREF $corefNode->{id}";
     }

     print "\n";
   }
   print "#EOS $nrSentences\n";

   $nrSentences++;
   return 1;
}

#------------------------------------------------------------------------------

&main();
1;

