#!/usr/bin/perl
<<DOC; 
Nom -- Elise LINCKER
Date -- AVRIL 2021

Traitement -- extraction de patrons morphosyntaxiques

Utilisation du programme -- perl bao3_extract_patrons.pl FICHIER_A_TRAITER FICHIER_PATRONS
Exemple d'utilisation -- perl bao3_extract_patrons.pl ./sortiesBAO2/BAO2_sortieUDpipe_3244.txt patrons.txt
Entrée -- le nom de la sortie UDPipe au format CONLL
          et le fichier TXT contenant la liste des patrons morpho-syntaxiques à extraire
Sortie -- autant de fichiers TXT que de lignes dans le fichier des patrons
          chacun contenant la liste triée des séquences qui correspondent au patron
DOC

use utf8;
binmode STDOUT, ':utf8';

#---------------------------------------------------------------------------------
my $fichierUDPipe="$ARGV[0]";
my $fichierPatrons="$ARGV[1]";

#---------------------------------------------------------------------------------
#on stocke les patrons écrits dans $fichierPatrons
open my $termino,"<:encoding(utf8)","$fichierPatrons";
my @patrons = <$termino>;
close($termino);

#---------------------------------------------------------------------------------
#extraction des patrons....

open my $IN ,"<:encoding(utf8)","$fichierUDPipe";

#on crée deux listes parallèles dans lesquelles on va stocker tous les tokens de chaque phrase et leurs pos 
my @token=();
my @pos=();

while (my $ligne=<$IN>) {
	
	#si la ligne commence par un #, ou si le token est une forme contractée
	#    exemple : 3-4 du
	#              3 de
	#              4 le
	#              --> on ignore la ligne qui commence par 3-4
	#alors il n'y a rien à traiter, et on passe à la ligne suivante
	next if $ligne=~m/^#|\d+-\d+/ ;

	$ligne=~s/\r?\n//g;
	
	#si la ligne n'est pas vide, on est toujours dans la même phrase :
	if ($ligne ne "") {
		#on ajoute aux listes le token et le pos récupérés dans la ligne
		my @ligne = split /\t/, $ligne;
		push @token, $ligne[1];
		push @pos, $ligne[3];
	}

	#sinon, c'est la fin de la phrase ---> on traite les listes
	else {

		#pour chaque patron $patron récupéré du fichier des patrons,
		foreach my $patron (@patrons) {
			
			$patron=~s/\r?\n//g;
			
			#on stocke dans la variable $longueurPatron la longueur du patron (<=> le nombre de POS à extraire pour ce patron)
			my $longueurPatron=0;
			while ($patron=~/ /g) {$longueurPatron++}
			
			my $i=0;
			#pour chaque POS $element de la liste @pos
			foreach my $element (@pos) {
				$i++;
				
				#si il correspond au premier POS du patron
				if ($patron =~/^$element/) {
					#on récupère dans la variable string $suitePOS toute la séquence de POS sur $longueurPatron caractères
					my $suitePOS="";
					my $j;
					for ($j=$i-1;$j<=$longueurPatron+$i-1;$j++) {$suitePOS=$suitePOS.$pos[$j]." "}
					
					#si $suitePOS (la suite de POS de longueur $longueurPatron récupérée) correspond au patron
					if ($suitePOS=~/$patron/) {
						#on concatène les tokens avec des espaces dans la variable $extract
						my $extract = join(" ", @token[$i-1..$j-1]);
						#et on l'ajoute au tableau du patron correspondant
						#(on crée le tableau si il n'existe pas encore)
						$dico{$patron} = [] unless exists $dico{$patron};
						push @{$dico{$patron}}, $extract;
						}
				}
			}
		}

	#on réinitialise les listes de tokens et de pos pour la phrase suivante
	@token=();
	@pos=();
	}
}

#on imprime les résultats obtenus pour chaque patron de manière indépendante
foreach my $patron (keys %dico) {
	#on crée un fichier de sortie pour le patron traité
	my $nomPatron = join("_",split(' ', $patron)); 
	open my $OUT,">:encoding(utf8)","BAO3_sortie_Perl_$nomPatron.txt";
	#on récupère le tableau qui correspond au patron traité
	my @extract = @{$dico{$patron}};
	#on crée une nouvelle table de hachage pour compter les occurrences de chaque séquence extraite
	my %extractFreq;
	++$extractFreq{$_} for @extract;
	#on trie par ordre décroissant de fréquence et on imprime dans le fichier la séquence suivie de son nombre d'occurrences
	foreach $unique (sort {$extractFreq{$b}<=>$extractFreq{$a}} (keys %extractFreq)) {
		print $OUT "$unique\t$extractFreq{$unique}\n";
	}
	close $OUT;
}