
package pms;
use Data::Dumper;
use strict;
use XML::LibXML;
#
#  Cherche des patrons morpho-syntaxiques dans une sortie tree-tagger
#  On la dérivera pour d'autres formats de sortie d'étiqueteurs
#  Un "patron" est ici une suite de 2 etiquettes
#
#  Ce constructeur prend en argument un triplet mot/tag/lemme à la tree-tagger
#  ou rien .Pour l'instant on ne traite qu'un patron à la fois.
#  Dans le cas où on construit un pms sans argument, il faut utiliser
#  la méthode read sur un corpus déja étiqueté.
#
sub new {
    my ($class,$refarr) = @_ ;
    $class = ref($class) || $class ;
    my $this = {};
    bless($this, $class);

    $this->{TABTAG} = ();      # liste des tags dans laquelle on cherche
    $this->{TPAT}  =();        #  table des patrons à chercher.
    $this->{FOUND} =();        # table de références vers les listes de mots.
    $this->{FILTR} =();        # idem mais listes filtrées par la méthode Filter.
    $this->{FDONE} = 0;        # 1 si il y a eu filtrage.

    if ( defined ($refarr) ) {
	$this->{REFARR} = $refarr; # un objet retourne par tagger
	foreach my $v (@$refarr) {
	    push ( @{$this->{TABTAG}} , $v->[1] );
	}
	$this->{NBTAG} = $#{$this->{TABTAG}};
    } else {
	$this->{REFARR} = undef ;
    }

    return $this;
}
#
# lit un corpus déja étiqueté et remplit les champs:
# $this->{REFARR}
# $this->{TABTAG}
# $file est le path du corpus étiqueté.
#
sub read {
    my ($this,$file) = @_ ; 
    open(FIC,"<$file") ;
    my $l ;
    while ( defined( $l = <FIC> ) ) {
	chomp $l;
	my @tab = ();
	@tab = split (/\t/ , $l);
	push ( @{$this->{REFARR}} , \@tab ) ;
    }
    foreach my $v (@{$this->{REFARR}}) {
	push ( @{$this->{TABTAG}} , $v->[1] );
    }
    $this->{NBTAG} = $#{$this->{TABTAG}};
    return ;
}
# 
# Donne à chercher un patron sous forme de chaine
#
sub search {
    my ($this,$text) = @_ ; 
    my @t = split (/[ \t]/ ,$text ) ;
    push ( @{$this->{TPAT}} , @t ) ;
    # pour l'instant un seul 
    my $pat = $this->{TPAT}; 
    my $loopend = $this->{NBTAG} - $#{$this->{TPAT}} + 1 ;
    for (my $i = 0; $i <= $loopend ; $i++ ) {
	my $match = () ; 
	my $j = $i;
	foreach my $p (@{$this->{TPAT}}) {
	    if (( $j <= $loopend ) && ($this->{TABTAG}->[$j] eq $p )) {
		push ( @$match , $this->{REFARR}->[$j]);
	    }
	    $j++ ;
	}
	# faudra voir si on les veut en + sieurs exemplaires.
	if ( $#$match == $#{$this->{TPAT}} ) {
	    my @ls = ();
	    foreach my $w (@$match) {
		push ( @ls , $w->[0] );
	    }
	    push ( @{$this->{FOUND}} , \@ls ) ;
	}
    }
    return ;
}
# 
# Exclut les patrons qui coincident avec pattern
# Le patron est exclus si les 2 éléments coincident 
# chacun pris séparément.
#
sub filterBoth {
    my ($this,$pattern) = @_ ; 
    foreach my $match (@{$this->{FOUND}}) {
	my $p1 = $match->[0] ;
	my $p2 = $match->[1] ;
	if ( (  $p1 !~ m/$pattern/ ) && ( $p2 !~ m/$pattern/ ) ) {
	    push ( @{$this->{FILTR}} , $match ) ;
	    $this->{FDONE} = 1;
	}
    }
    return
}
#
# retourne les occurences comme un fichier texte
# 
sub getPMSAsText {
    my ($this, $file ) = @_ ;
    open(FIC,">$file") ;
    my $refpatrons = ( $this->{FDONE} == 1 ) ? $this->{FILTR} : $this->{FOUND}   ;
    foreach my $match (@{$refpatrons}) {
	my $strm = "";
	foreach my $w (@$match) {
	    $strm = $strm . " " . $w ;
	}
	$strm =~ s/^ //;
	print FIC $strm , "\n" ;
    }
    close(FIC);
    return ;
}
#
# retourne les occurrences au format Pajek .net
# 
sub getPMSAsPajek {
    my ($this, $file ) = @_ ;
    my %MAP = () ;
    # On créé une MAP de travail au format :
    # MAP{$KEY} = $VAL avec $KEY = 'crise';$VAL = {'sociale' => 5,'politique' => 2,..}
    my $refpatrons = ( $this->{FDONE} = 1 ) ? $this->{FILTR} : $this->{FOUND}   ;
    foreach my $match (@{$refpatrons}) {
	my $key = $match->[0] ;
	my $val = $match->[1] ;
	if ( exists ( $MAP{$key}  )) {
	    my $ref = $MAP{$key} ;
	    if ( exists ( $ref->{$val} ) ) {
		$ref->{$val} = $ref->{$val} + 1 ;
	    } else {
		$ref->{$val} =  1 ;
	    }
	} else {
	    $MAP{$key} = { $val => 1 } ;
	}
    }
    # print Dumper ( %MAP ) ;
    # la map vertices pour avoir des vertices en exemplaire unique 
    #
    my %vertices = () ;
    my $i = 1;
    while ( my ($key,$val) = each(%MAP) ) {
	if ( ! exists ($vertices{$key} )) {
	    $vertices{$key}=$i;
	    $i++ ;
	}
	
	foreach my $v (keys %{$val}) {
	    if ( ! exists ($vertices{$v} )) {
		$vertices{$v}=$i;
		$i++ ;
	    }
	}
    }
    # 
    # on parcourt tous les vertices pour faire des edges.
    #   *Vertices 208 
    #   1 "tournoi"
    #   2 "qualificatif"
    #   3 "secrétaire"
    #
    open(FIC,">$file") ;
    my %unvertices = reverse(%vertices) ;
    print FIC sprintf("*Vertices %s\n", scalar((keys %vertices)));
    foreach my $v (sort { $a <=> $b } (keys %unvertices)) {
	print FIC $v , " " , "\"$unvertices{$v}\"" ,  "\n" ; 
    }
    print FIC "*Edges \n";
    # edge1 edge2 freq
    while ( my ($key,$val) = each(%MAP) ) {
	foreach my $v (keys %{$val}) {
	    print FIC $vertices{$key} , " " , $vertices{$v} , " " , $val->{$v} , "\n" ;
	}  
    }
    close(FIC);
    return ;
}
#
# Idem que ci dessus au format GraphML 
# ( ne fonctionne qu'avec des patrons de 2 motifs ??) 
#
sub getPMSAsGraphML {
    my ($this, $file , $enc ) = @_ ; 
    my %listeMot={};
    my %listePatron={};
    my $refpatrons = ( $this->{FDONE} = 1 ) ? $this->{FILTR} : $this->{FOUND}   ;
    foreach my $match (@{$refpatrons}) {
	my $mot1= $match->[0] ;
	my $mot2= $match->[1] ;
	my $patron="$mot1\t$mot2";
	if (!(exists($listeMot{$mot1}))) {
	    my @tmp=();
	    push(@tmp,$mot2);
	    $listeMot{$mot1}=\@tmp;
	    $listePatron{$patron}++;
	}
	else {
	    my $tmp=$listeMot{$mot1};
	    my @tmp2=@$tmp;
	    if (!(grep(/$mot2/, @tmp2))) {
		push(@tmp2,$mot2);
	    }
	    $listeMot{$mot1}=\@tmp2;
	    $listePatron{$patron}++;
	}
	
    }

#<graphml>
#<key id="d0" for="node" attr.name="forme" attr.type="string"/>
#<key id="d1" for="edge" attr.name="frequence" attr.type="double"/>;
#<graph edgedefault="undirected">

    my $dom = XML::LibXML::Document->createDocument( "1.0", $enc );
    my $graphml = $dom->createElement( "graphml" );
    $dom->setDocumentElement($graphml );
    my $nod ;
    $nod = $dom->createElement("key");
    $nod->setAttribute("id","d0");
    $nod->setAttribute("for","node");
    $nod->setAttribute("attr.name","forme");
    $nod->setAttribute("attr.type","string");
    $graphml->appendChild($nod);
    $nod = $dom->createElement("key");
    $nod->setAttribute("id","d1");
    $nod->setAttribute("for","edge");
    $nod->setAttribute("attr.name","frequence");
    $nod->setAttribute("attr.type","double");
    $graphml->appendChild($nod);
    my $graph = $dom->createElement("graph");
    $graph->setAttribute("edgedefault","undirected");
    $graphml->appendChild($graph);

    my $id=1;
    my %listeId={};
    my $mot = "" ;
    my $liste = [] ;
    print "----------------------------------\n" ;
    while (($mot, $liste) = each(%listeMot)) {
	
	if ($mot !~/HASH/) {
	    my @tmp=@$liste;
	    my $tmpID;
	    if (!(exists($listeId{$mot}))) {
		my $nw ;
		my $data ;
		#<node id="$id"><data key="d0">$mot</data></node>
		$nw = $dom->createElement("node");
		$nw->setAttribute("id",$id);
		$graph->appendChild($nw);
		$data = $dom->createElement("data");
		$data->setAttribute("key","d0");
		$data->appendTextNode($mot);
		$nw->appendChild($data);
		$graph->appendChild($nw);
		$listeId{$mot}=$id;
		$tmpID=$id;
		$id++;
	    } else {
		$tmpID=$listeId{$mot};
	    }
	    foreach my $cible (@tmp) {
		my $nbpatron=0;
		my $patron="$mot\t$cible";
		$nbpatron=$listePatron{$patron};
		if (!(exists($listeId{$cible}))) {
		    my ( $nw , $data );
		    #<node id="$id"><data key="d0">$cible</data></node>
		    $nw = $dom->createElement("node");
		    $nw->setAttribute("id",$id);
		    $graph->appendChild($nw);
		    $data = $dom->createElement("data");
		    $data->setAttribute("key","d0");
		    $data->appendTextNode($cible);
		    $nw->appendChild($data);
		    $graph->appendChild($nw);
		    $listeId{$cible}=$id;
		    #<edge source="$tmpID" target="$id"><data key="d1">$nbpatron</data></edge>
		    my ( $nw1 , $data1 );
		    $nw1 = $dom->createElement("edge");
		    $nw1->setAttribute("source",$tmpID);
		    $nw1->setAttribute("target",$id);
		    $data1 = $dom->createElement("data");
		    $data1->setAttribute("key","d1");
		    $data1->appendTextNode($nbpatron);
		    $nw1->appendChild($data1);
		    $graph->appendChild($nw1);
		    $id++;
		} else {
		    #<edge source="$tmpID" target="$listeId{$cible}><data key="d1">$nbpatron</data></edge>
		    my ( $nw2 , $data2 );
		    $nw2 = $dom->createElement("edge");
		    $nw2->setAttribute("source",$tmpID);
		    $nw2->setAttribute("target",$listeId{$cible});
		    $data2 = $dom->createElement("data");
		    $data2->setAttribute("key","d1");
		    $data2->appendTextNode($nbpatron);
		    $nw2->appendChild($data2);
		    $graph->appendChild($nw2);
		}
	    }
	}
	
    } 

    $dom->toFile($file, 2);
    return ;
    
}
#
# Idem que ci dessus mais comme un document XML 
# 
sub getPMSAsDocument {
    my ($this, $file , $enc ) = @_ ; 
    my $dom = XML::LibXML::Document->createDocument( "1.0", $enc );
    my $patrons = $dom->createElement( "patrons" );
    $dom->setDocumentElement( $patrons );
    my $pat = $this->{TPAT}; # pour l'instant un seul 

    my $i ;
    my $pt = $dom->createElement("patron");
    for (my $i = 0; $i <= $this->{NBTAG}; $i++ ) {
	my $match = () ; 
	my $j = $i;
	foreach my $p (@{$this->{TPAT}}) {
	    if ($this->{TABTAG}->[$j] eq $p ) {
		push ( @$match , $this->{REFARR}->[$j]);
	    }
	    $j++ ;
	}
    
	if ( $#$match == $#{$this->{TPAT}} ) {
	    $pt->setAttribute("string", join (" ", @{$this->{TPAT}}) );
	    my $strm = "";
	    foreach my $w (@$match) {
		$strm = $strm . " " .$w->[0];
	    }
	    my $ma = $dom->createElement("occur");
	    $ma->setAttribute("match",substr($strm,1,length($strm)));
	    $pt->appendChild($ma);
	    $patrons->appendChild($pt);
	}
    }
    $dom->toFile($file, 2);

    return ;
}

1;
