#!/usr/bin/perl

#####
# .extractEN.pl resultat_analyse_f_passage.xml > fichier_sorti.xml
#		+ Ressource utilisée : patrons.txt = liste des patrons de relations à extraire
#		- acquisition de nouvelles ENs à l'aide des partorns-chemins de relations 
#####
use strict;

my @tokens;
my %mots;
my %lemmes;
my %mcats;
my %GPcat;
my %mot2GP;
my $tid=0;
my $phrase= "";
my $wid=0;
my $GPid=0;
my $RType="";
my @RTypes;
my $Rdependant;
my $Rdependu;
my @R;
my %newEN;
my %contextes;
my $key;

my $cmp=0;
my $phr=0;

my @tmp;
my $sentence;

if( @ARGV!= 1){
	die "Erreur : $0 fileName \n"; # $0はプログラム名
}
open FIN, $ARGV[0]
	or die "Erreur : Impossible d'ouvrir le fichier\n\n";

open PATRONS, "<patrons.txt"
	or die "Erreur : Impossible d'ouvrir le fichier patrons.txt\n\n";

open PROPOS, ">propositions.txt"
	or die "Erreur : Impossible d'ouvrir le fichier propositions.txt\n\n";

### patron
my @lpat;
my @nd2lemme;
my @noeuds;
my @ndTypes;
my @arcs;
my $relation;

while(<PATRONS>){
	push(@lpat, $_);
}
print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
print "<?xml-stylesheet type='text/css' href='fstymatch.css'?>\n\n";
print "<resultat>\n\n";

while(<FIN>)
{
	chomp;
	if(/(<Sentence id=\")([^"]+)(\".+>)/){		
		$phr++;
		#print STDERR "$2 ";
		if($phr%1000==0){
			print STDERR "$phr-";
		}
		$sentence="$1$2$3";
		
	}
	### Matching
	if(/^\s+(<\/Sentence)/){
		#print STDERR "-";
		foreach(@lpat){
			if(/^\#/){ next; }
			if(/^([^;]+)\;([^;]+)\;([^;]+)\;([^;]+)\;/){
				@noeuds=split /:/, $1; #patron
				@ndTypes=split /:/, $2;
				@arcs=split /:/, $3;
				$relation=$4;
				#print STDERR @noeuds . @ndTypes . @arcs;
				#print STDERR @ndTypes;
				#print STDERR @arcs;
				&Matching;
				#@noeuds=("","président","");  # photographe, entraîneur, représentant, professeur, responsable
				#@ndTypes=("_PERSON","nc","_ORGANIZATION"); #
				#@arcs=("0,APPOS,1", "2,MOD-N(de),1");
				#&Matching;
				#@noeuds=("","tête","");
				#@arcs=("1,MOD-N(à),0", "2,MOD-N(de),1");
				#&Matching;
			}
		}
		@tmp =(); $phrase=""; @tokens=(); %mots=(); %mcats=(); %lemmes=(); %mot2GP=(); %GPcat=();
		@RTypes=();	@R=();
	}

	### Traitement phrase par phrase
	###   stockage des données dans les tableaux
	if($tid>0){				
		if(/<\/T/){ $tid=0; }
		elsif(/\s+(\")$/){
			$phrase.="\\g ";
			$tokens[$tid-1]="$1";
		}
		elsif(/\s+(.+)$/){
			$phrase.=$1 . " ";
			$tokens[$tid-1]="$1";
		}
		next;
	}
	if(/<T id="[^"]+T(\d+)"/){		
		$tid=$1;
	}

	## _PERSON = adj ==> Entité nommée
	if(/<W id="[^"]+F(\d+)" pos="(adj)" lemma="([^"]+)" form="(_PERSON[^"]+)" tokens="([^"]+)"/){
		$wid=$1;		
		$mots{$wid}=$5;
		$lemmes{$wid}=$3;
		$mcats{$wid}=$4;
	}
	## _COMPANY ===> Entité nommée (organization ?)
	elsif(/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_COMPANY)" tokens="([^"]+)"/){		
		$wid=$1;		
		$mots{$wid}=$5;
		$lemmes{$wid}=$3;
		$mcats{$wid}=$4;
	}
	
	## Entité nommée reconnue => insertion de la forme effective
	elsif(/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_ORGANIZATION)" tokens="([^"]+)"/||
	/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_DATE[^"]*)" tokens="([^"]+)"/||
	/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_PERSON[^"]*)" tokens="([^"]+)"/||
	/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_LOCATION[^"]*)" tokens="([^"]+)"/||
	/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="(_NUMBER[^"]*)" tokens="([^"]+)"/
	){		
		$wid=$1;		
		$lemmes{$wid}=$3;
		$mcats{$wid}=$4;
		$mots{$wid}=$5;
	}
	## Nom commun
	elsif(/<W id="[^"]+F(\d+)" pos="([^"]*)" lemma="([^"]+)" form="([^"]+)" tokens="([^"]+)"/){		
		$wid=$1;		
		$mots{$wid}=$5;
		$lemmes{$wid}=$3;
		$mcats{$wid}=$2;
	}
	## Nom commun avec '
	elsif(/<W id="[^"]+F(\d+)" pos="[^"]*" lemma='([^']+)' form='([^']+)' tokens="([^"]+)"/){		
		$wid=$1;		
		$mots{$wid}=$5;
		$lemmes{$wid}=$3;
		$mcats{$wid}=$2;
	}
	elsif(/<W id="[^"]+F(\d+)" pos="[^"]*" lemma='([^']+)' form="([^"]+)" tokens="([^"]+)"/){		
		$wid=$1;		
		$mots{$wid}=$5;
		$lemmes{$wid}=$3;
		$mcats{$wid}=$2;
	}
	## Stockage de "prep" de GP
	if($GPid > 0 && /<W id="[^"]+F(\d+)"/){
		$wid=$1;		
		$mot2GP{$1}=$GPid;
		if(/ pos="prep" lemma="([^"]+)"/){
			$GPcat{$GPid}=$1;
		}
		elsif(! exists($GPcat{$GPid}) && / pos="prel" lemma="([^"]+)"/){
			$GPcat{$GPid}=$1;
		}
	}
	elsif(/<G id="[^"]+G(\d+)" type="GP"/){		
		$GPid=$1;
	}
	elsif(/<\/G/){		
		$GPid=-1;
	}

	if(/<R type="([^"]+)" id="[^"]+"/){		
		$RType=$1;
	}
	### Stocage des arcs
	### ---> indication de la préposition : ex. MOD-N(de)
	elsif(/<\/R/){
		$Rdependant= shift @tmp;	
		$Rdependu= shift @tmp;
		$GPid=$mot2GP{$Rdependant};
		if(exists($GPcat{$GPid}) && $RType ne "JUXT" && $RType ne "APPOS" && $RType ne "COORD"){
			my $tcat=$GPcat{$GPid};
			#print "$Rdependant,$RType($tcat),$Rdependu\n";
			push (@R, "$Rdependant,$RType($tcat),$Rdependu");
		}else{
			#print "$Rdependant,$RType,$Rdependu\n";
			push (@R, "$Rdependant,$RType,$Rdependu");
		}
		$RType=""; $GPid=-1; @tmp=();
	}
	elsif($RType ne ""){
		if(/ ref="[^"]+F(\d+)"/){		
			push(@tmp, $1);
		}
	}
}
print "\n\n</resultat>\n";
my %ltriee;
foreach $key ( keys %newEN ) {
	my $keytmp=$newEN{$key}."\t".$key.$contextes{$key}."\n";
	$ltriee{$keytmp}= $newEN{$key};
}
my @keys = sort {$ltriee{$b} <=> $ltriee{$a}} keys %ltriee;
print PROPOS "@keys\n";

print STDERR "\n\nNombre de phrases traitées : $phr\n";
print STDERR "Nombre de instances extraites : $cmp\nTerminé !\n\n";


############## Sous-programmes ###############

sub Matching{
		my $resultat=0; 
		my $key;
		my $value;
		my $i=1;
		my $nb=0;
		@nd2lemme=();
		### Recherche des noeuds identiques de @noeuds[$i]
		while ( ($key, $value) = each(%lemmes) ) {
			if($value eq @noeuds[$i] && $mcats{$key} eq @ndTypes[$i]){
				$nd2lemme[$i]=$key;
				### noeud pivot trouvé !
				foreach(@arcs){
					### arc traité = arc sortant : ($i=$key,$deptype,?)
					if(/\b$i\,([^,]+)\,(\d+)/){
						my $deptype=$1;
						my $depid=$2;
						#print STDERR "($i->$key,$deptype,?)\n";
						### recherche d'un même type d'arc
						foreach(@R){
							#print STDERR "$_\n";
							if(/\b$key\,([^,]+)\,(\d+)/){
								my $tmpid=$2;
								if($1 eq $deptype && $mcats{$tmpid} ne "adj"){ # bon type d'arc et élément relié non "adj"
									#print STDERR "$_\n";
									unless($nd2lemme[$depid]>0){ 
										$nd2lemme[$depid]=$tmpid;
										if($mcats{$tmpid}=~/$ndTypes[$depid]/){ last; }
									}
									else{ # il y a déjà un identifiant
										my $tmp2=$nd2lemme[$depid]; # id actuellement stocké = type incorrect
										if($mcats{$tmpid}=~/$ndTypes[$depid]/){# le nouveau = type correct
											$nd2lemme[$depid]=$tmpid;
											last;
										}
										if($mcats{$tmp2}=~/^\_/){ # id actuellement stocké = autre type d'EN
											$nd2lemme[$depid]=$tmpid;
										}
									}
									# sinon on garde ce qu'on a trouvé le premier ... ???
								}
							}
						}
					}
					### arc traité = arc entrant : (?,$deptype,$i=$key)
					if(/(\d+)\,([^,]+)\,$i\b/){
						my $deptype=$2;
						my $depid=$1;
						#print STDERR "($depid->?,$deptype,$i->$key)\n";
						foreach(@R){
							if(/(\d+)\,([^,]+)\,$key\b/){
							#if(/(\d+)\,$deptype\,$key\b/){
								my $tmpid=$1;
								if($2 eq $deptype && $mcats{$tmpid} ne "adj"){
									#print STDERR "$_\n";
									#$nd2lemme[$depid]=$tmpid;
									unless($nd2lemme[$depid]>0){ 
										$nd2lemme[$depid]=$tmpid;
										if($mcats{$tmpid}=~/$ndTypes[$depid]/){ last; }
									}
									else{ # il y a déjà un identifiant
										my $tmp2=$nd2lemme[$depid]; # id actuellement stocké = type incorrect
										if($mcats{$tmpid}=~/$ndTypes[$depid]/){# le nouveau = type correct
											$nd2lemme[$depid]=$tmpid;
											last;
										}
										if($mcats{$tmp2}=~/^\_/){ # id actuellement stocké = autre type d'EN
											$nd2lemme[$depid]=$tmpid;
										}
									}
									# sinon on garde ce qu'on a trouvé le premier ... ???
								}
							}
						}
					}
				}

				###### Examen du résultat ######
				$resultat=0;
				#print "@nd2lemme\n";
				print STDERR ">";
				if(@nd2lemme==@noeuds && $nd2lemme[0]!=$nd2lemme[-1]){
					foreach(@nd2lemme){
						if($_ ne ""){
							$resultat++;
						}
					}
					if($resultat==@noeuds){
						###### résultat trouvé !
						# Préparation du résultat à fournir
						$cmp++;
						my $id=shift @nd2lemme;
						my $id_centre=shift @nd2lemme;
						my $en=&insereTokens($mots{$id});
						my $en_new =&inclureDependants($id, $id_centre);
						my $entype=$mcats{$id};
						if($en ne $en_new && ($en_new =~ /$en/)){ ## pour éviter la nouvelle chaîne plus courte
							print "\n<relation id=\"".$cmp."\" nom=\"". $relation . "\" en1=\"". $en_new . "\" type1=\"" . $entype . "\"  en1_old=\"". $en . "\" ";
							#print STDERR "$en->$en_new\n";
						}else{
							if($en ne $en_new){ $en_new=$en; }
							print "\n<relation id=\"".$cmp."\" nom=\"". $relation . "\" en1=\"". $en . "\" type1=\"" . $entype . "\" ";
						}
						if($entype =~ /$ndTypes[0]/ || ($entype eq "_COMPANY" && $ndTypes[0] eq "_ORGANIZATION")){ # pas de correction
							$phrase=~s/($en_new)/<en1>$1<\/en1> <type>\($entype\)<\/type>/g;
							print "prop_corr1=\"\" ";
						}
						else{ #--> proposition de correction
							if($entype eq "_LOCATION" && $ndTypes[0] eq "_ORGANIZATION"){
								$phrase=~s/($en_new)/<en1>$1<\/en1> <type>\($entype --> $ndTypes[0] par mét\.\)<\/type>/g;
								print "prop_corr1=\" ". $ndTypes[0] . " par mét.\" ";
								$key=$en_new . ";" . $ndTypes[0] . " par mét.\n";
							}
							elsif($en eq $en_new && $entype eq "nc"){
								$phrase=~s/($en_new)/<en1>$1<\/en1> <type>\($entype --> $ndTypes[0] anaphorique\)<\/type>/g;
								print "prop_corr1=\" ". $ndTypes[0] . " anaphorique\" ";
								$key=$en_new . ";" . $ndTypes[0] . " anaphorique\n";
							}
							else{
								$phrase=~s/($en_new)/<en1>$1<\/en1> <type>\($entype --> $ndTypes[0]\)<\/type>/g;
								print "prop_corr1=\" ". $ndTypes[0] . "\" ";
								$key=$en_new . ";" . $ndTypes[0] . "\n";
							}
							if(exists($newEN{$key})){
								$newEN{$key}+=1;
								$contextes{$key}.="\t$phrase\n";
							}else{
								$newEN{$key}=1;
								$contextes{$key}="\t$phrase\n";
							}

						}
						$id=pop @nd2lemme;
						$en=&insereTokens($mots{$id});
						$en_new=&inclureDependants($id, $id_centre);
						$entype=$mcats{$id};
						if($en ne $en_new && ($en_new =~ /$en/ )){
							print "en2=\"". $en_new ."\" type2=\"" . $entype . "\" en2_old=\"". $en . "\" ";
							#print STDERR "$en->$en_new\n";
						}else{
							if($en ne $en_new){ $en_new=$en; }
							print "en2=\"". $en ."\" type2=\"" . $entype . "\" ";
						}
						if($entype=~/$ndTypes[-1]/ || ($entype eq "_COMPANY" && $ndTypes[-1] eq "_ORGANIZATION")){ # pas de correction
							$phrase=~s/($en_new)/<en2>$1<\/en2>  <type>\($entype\)<\/type>/g;
							print "prop_corr2=\"\" \/>\n";
						}
						else{ #--> proposition de correction
							if($entype eq "_LOCATION" && $ndTypes[-1] eq "_ORGANIZATION"){
								$phrase=~s/($en_new)/<en2>$1<\/en2> <type>\($entype --> $ndTypes[-1] par mét\.\)<\/type>/g;
								print "prop_corr2=\" ". $ndTypes[-1] . " par mét.\" \/>\n";
								$key=$en_new . ";" . $ndTypes[-1] . " par mét.\n";
							}
							elsif($en eq $en_new && $entype eq "nc"){
								$phrase=~s/($en_new)/<en2>$1<\/en2> <type>\($entype --> $ndTypes[-1] anaphorique\)<\/type>/g;
								print "prop_corr2=\" ". $ndTypes[-1] . " anaphorique\" \/>\n";
								$key=$en_new . ";" . $ndTypes[-1] . " anaphorique\n";
							}
							else{
								$phrase=~s/($en_new)/<en2>$1<\/en2> <type>\($entype --> $ndTypes[-1]\)<\/type>/g;
								print "prop_corr2=\" ". $ndTypes[-1] . "\" \/>\n";
								$key=$en_new . ";" . $ndTypes[-1] . "\n";
							}
							if(exists($newEN{$key})){
								$newEN{$key}+=1;
								$contextes{$key}.="\t$phrase\n";
							}else{
								$newEN{$key}=1;
								$contextes{$key}="\t$phrase\n";
							}

						}
						$nb++;
					}
				}
			 	@nd2lemme=();
			}
		}
		if($nb>0){ print $sentence . $phrase . "</Sentence>\n"; }
		$nb=0;

}

sub insereTokens{
	#print STDERR "$_[0]\n";
	my $token=$_[0];
	my $ch="";
	while(1){
			if($token =~ /[^T]+T(\d+)/){
				my $i=$1-1;
				$token = $';
				if($ch ne ""){ $ch .= " "; }
				#print STDERR "$tokens[$i]\n";
				$ch .= "$tokens[$i]";
			}else{ last;}
	}
	
	return $ch;
} 

sub inclureDependants{
	#print STDERR "id_centre = $_[1]\n";
	my $id=$_[0];
	my $id_centre=$_[1];
	# chercher les éléments dépendants
	my @liste=&chercherDependants($id, $id_centre);
	unshift(@liste, $id);
	# vérification des éléments du même groupe
	my $i=$id+1;
	while(1){
		if($mot2GP{$id}==$mot2GP{$i} && $mcats{$i} eq "np"){
			if(grep( $i, @liste ) <= 0){
				push(@liste, $i);
			}
			#print STDERR "($id, $i) ";
			$i++;
		}else{
			last;
		}
	}

	# mise en l'ordre linéaire d'apparition des indices
	my @sort_array = sort {$a <=> $b} @liste;
	#print STDERR "@sort_array\n";
	my $ch;

	my $i=$sort_array[0];
	my $fin=$sort_array[-1];
	my $virgule=0;
	my $precedent=100000;
	#foreach(@sort_array){
	while($i<=$fin){
			#my $token=$mots{$_};
			if($mcats{$i} eq "prel"){
				#print STDERR "Cat mot = $mots{$i} : $mcats{$i}\n";
				last; 
			}
			my $token=$mots{$i};
			while(1){
					if($token =~ /[^T]+T(\d+)/){
						my $i=$1-1;
						$token = $';
						if($precedent==$i){
							next;
						}
						$precedent=$i;
						if($tokens[$i] =~ /\,/){
							$virgule=1;
							last;
						}
						if($ch ne ""){ $ch .= " "; }
						$ch .= "$tokens[$i]";
						#print STDERR "$tokens[$i]\n";
					}else{ last;}
			}
			if($virgule==1){last;}
			$i++;
	}	
	
	
	$ch=~s/\"/\/g/g;
	#print STDERR "$ch\n";
	return $ch;
} 

sub chercherDependants{
	my $id=$_[0];
	my $id_centre=$_[1];
	my @liste;
	
	#print STDERR "chercherDependants : $id, $id_centre\n";
	#print STDERR "@R\n";

	foreach(@R){
		# Recherche des éléments dépendants
		if(/\b(\d+)\,([^,]+)\,$id/ && $1!=$id_centre){
			# il existe un élément dépendant qui n'est pas l'unité lexicale de chemin
			my $id_new=$1;
			my $type=$2;
			if(($id < $id_new && $id+3 >= $id_new) && ($type =~ /MOD-N/ || $type =~ /APPOS/)){
				#print STDERR "il existe un élément dép : $id<-$id_new\n";
				push(@liste, $id_new);
				push(@liste, &chercherDependants($id_new, $id_centre));
			}
			elsif($id-1 == $id_new && ($type =~ /MOD-N/ || $type =~ /APPOS/)){
				# pour les adj antéposé
				#print STDERR "il existe un adj antéposé : $id<-$id_new\n";
				push(@liste, $id_new);
				#push(@liste, &chercherDependants($id_new, $id_centre));
			}
		}
		# Recherche des éléments régissants pour APPOSITION
		elsif(/\b$id\,([^,]+)\,(\d+)/ && $2!=$id_centre){
			# il existe un élément dépendant qui n'est pas l'unité lexicale de chemin
			my $id_new=$2;
			my $type=$1;
			if($id < $id_new && ($type =~ /APPOS/)){
				#print STDERR "il existe un élément dép : $id<-$id_new\n";
				push(@liste, $id_new);
				push(@liste, &chercherDependants($id_new, $id_centre));
			}
			elsif($id-1 == $id_new && ($type =~ /APPOS/)){
				# pour les appos antéposé
				#print STDERR "il existe un appos antéposé (dépendu) : $id<-$id_new\n";
				push(@liste, $id_new);
				#push(@liste, &chercherDependants($id_new, $id_centre));
			}
		}
	}
	
	
	
	return @liste;
} 


