#!/usr/bin/perl -w

###########################################################
#Para validação do formato árvores deitadas da Floresta Sintáctica
#
#Script desenvolvido por Jose Joao Almeida, jj@di.uminho.pt
#
#Modificado por Rui Vilela, ruivilela@di.uminho.pt
#
#perl validar_bosque bosque.txt [-etq descEtiquetas.txt] [-stat estatisticas.txt] [> erros.txt]
###########################################################

use POSIX qw(locale_h);
setlocale(LC_CTYPE, "pt_PT");
use locale;

use strict;
use Getopt::Long;
use Data::Dumper;

my $etq="..\/metadados\/descEtiquetas.txt";
my $stat="estatisticas.txt";

GetOptions(
	   "etq=s" => \$etq, 
	   "stat=s" => \$stat
);

my @serros=(
	    "T01) Salto de nível na indentação superior a 1 nível",
	    "T02) Classificação da palavra, depois da informação morfológica",
	    "T03) Carácter inválido (espaço,<,>,=)",
	    "T04) Nó raiz não especificado correctamente",
	    "T05) Depois da referência à frase, falta 'A?' ou há linha em branco",
	    "T06) Linha em branco detectada entre A? e \&\& (Ausência de \&\& ?)",
	    "T07) Nó não terminal sem o correspondente aumento de nível de indentação",
	    "T08) Nó terminal usado como nó não terminal com respectiva subida de nível de indentação",
	    "T09) Pontuação usada como nó não terminal com respectiva subida de nível de indentação",
	    "T10) Falta ':' no ramo não terminal",
	    "T11) Falta ':' ou espaços a mais",
	    "T12) Parece ser um verbo com lema estranho",
	    "T13) Dupla numeração de análise sintáctica alternativa",
	    "T14) Confirmar se o lema não será 'poder'",
	    "T15) Duplicação de etiqueta secundária",
	    "T16) Parêntises a mais em nó terminal",
	    "T17) Falta espaço entre a última pelica e a informação secundária ou morfológica",
	    "T18) Excesso de ':'",
	    "T19) Lema não delimitado correctamente por pelicas",
	    "T20) Identificador de fonte (SOURCE), mal estruturado",
	    "T21) Etiqueta de função com letra(s) minúscula(s)",
	    "T22) Etiqueta de forma com letra(s) maiúscula(s)",
	    "T23) Omitida etiqueta de forma",
	    "T24) Etiqueta de forma desconhecida",
	    "T25) Etiqueta de função desconhecida",
	    "T26) Etiqueta secundária desconhecida",
	    "T27) Combinação inválida da etiqueta de função e forma",
	    "T28) Subida de nível não esperado para o ramo raiz",
	    "T29) Nó inválido como ramo raiz",
	    "T30) Espaço em branco na palavra",
	    "T31) Sem lema especificado",
	    "T32) Verificar o lema com a palavra", #Caso particular dos '' para indicar segundos
	    "T33) Nodo incorrectamente estruturado", #problema dos nodos com números enclausurados
	    "T34) Parêntesis à volta do lema em falta",
	    "T35) Espaço a mais entre nodos da árvore",
	    );

my %erros;
#---------
my @forma;
my @funcao;
my @extra;
my $ETIQ;

open $ETIQ, "<$etq" or die "$!";

my $act;
my $et;

# le etiquetas para comparação
while (<$ETIQ>){
  if (/^(.+):--$/){
     $act=$1;
     $act="formas" if ($act eq "catpos");
     $act="funcao" if ($act eq "label");
     $act="extras" if ($act eq "extra");
  }elsif (/^\s+(.+):/){
      $et=$1;
      push @forma, $et if ($act=~/for/);
      push @funcao, $et if ($act=~/func/);
      push @extra, $et if ($act=~/extr/);
  }

}
close $ETIQ;


my ($nivelant, $palant, $nivel,$tn,$tmp)=(0,0,0,"?","");
my @prim_desc=(); my @pd=(); my @ud=(); #descontinuidades
my $pass=0; #Evitar repetição de erros;

while(<>){
 chomp;
 if(/^=+/){$nivel = length($&)}
 else     {$nivel = 0;}
 if(/^(C[PF]\d+-\d+)/ ){$tn=$1;}
 if($nivel > $nivelant+1){
     err(1,$palant,$_) ;
 } if (/[FM] [SP] \</){
     err(2,$_) ;
  } if (/.*\(\'.*[^?\$!\'\\«»:\/,&%-.\w]+.*\'.*\).*/i && !/\d \'/) {
     err(3,$_) ;
  } if ($palant=~/A\d/ && $_!~/\w*:\w*/){
#     err(4,$_) ;             #Repetido
  } if($palant=~/^C[PF]/ && $_!~/^A1/){
     err(5,$palant,$_) ;
  } if($palant!~/^[=]?&&/ && /^(A[2-9])/){
     err(6,$palant,$_) ;
  } if( $nivel > 0 && $nivel <= $nivelant && ! t($palant) && ! p($palant)){
     err(7,$palant,$_) ;
  } if($nivel == $nivelant+1 && t($palant)){
#    err(8,$palant,$_) ;      #ignorar por agora
  } if( $nivel > 1 && $nivel == $nivelant+1 && p($palant)){
      err(9,$palant,$_) ; $nivelant=$nivel; $palant = $_; next; #ignora o facto de não existir : no construtor
  } if( $nivel > 1 && $nivel == $nivelant+1 && $palant !~/:/){
     err(10,$palant) ;
  } if(! /^C/  &&  !/:/ && t($_)){
     err(11,$_) ;
  } if(/:v-/ && ! /r\'/){
     err(12,$_) ;
  } if($palant=~/A[\d]/ && $_=~/A[\d]/){
     err(13,$palant,$_) ;
  } if(/'podar'/ && /pode/){
     err(14,$_) ;
  } if(&duplic($_)){
     err(15,$_);
 } if (/\(\(/){
     err(16,$_);
 } if ((/\(\'.+\'(.*)\)/) && ( $1=~/^[^ \)]/)){
     err(17,$_);
 } if (/::/){ 
     err(18,$_);
 } if ((!/^C[FP]\d/) && (!/\'[\(\)]+\'/) && (/\(\'[^\']*\)/ || /\([^\']*\'[^\']*\)/ )){
     err(19,$_);
 }
 if (/^<ext/ && !/^<ext (n|id)=\d+ (cad=\"[\w\s\!]+\" )?sec=\"?[\w\-]+\"? sem=\"?\d+\w\"?>\s*$/){
     err(20,$_);
 }
 if (/^=*\W*[a-z]+\W*:/){
     err(21,$_);
 }
 if (/:[A-Z]+/){
     err(22,$_);
 }
 if (/:\(/){
     err(23,$_);
 } 
 if (/:([a-z\?\-\/]+)\(/){   ##Nota: as etiquetas de discontinuidade não são verificadas
     $tmp=$1;       #Descontinuidade
     $tmp=~s/-$//;
     if (!(grep(/\b\Q$tmp\E\b/,@forma)) && ($tmp!~/\? ?$/)){
	 err(24,$_);
     }
 } 

 if (!/^SOURCE/ && /^=*([A-Z\&\-\<\>]+?):/){
     #print STDERR "$1\n";
     $tmp=$1;
     $tmp=~s/^-//; #Descontinuidade
     my $z=1;
     foreach $a (@funcao){
	 if ($tmp eq $a){
	     $z=0;
	     last;
	 }
     }
     if ($z){
	 #print STDERR "$_\n";
	 err(25,$_);
	 $z=0;
     }
 } 
 if (/\([^<>]*<([^<>]+)>.*\)/){   ###Falta verificar + do que uma etiqueta
     $tmp=$1;
     if (!(grep(/\Q$tmp\E/,@extra)) && ($tmp!~/predicate|pcp/)){
	 err(26,$_);
     }
 } 

 if (!/^SOURCE/ && /^=*[A-Z]+?(.?)[a-z]+?/){
     if ($1 ne ':'){
	 #print STDERR "$_\n";
	 err(27,$_);
     }
 } 

 if ($palant=~/\s*A\d\s*/ && /^=/){
     #print STDERR "$palant --$_\n";
     err(28,$palant,$_);

 }

 if ($palant=~/^=/ && !/^=/ && !/^A\d/ && /^\S/ && !/^</ && !/^[=]?&&/){
     err(29,$palant,$_);
 }

 if (/^=*[A-Z\?\-\>\<]+:[a-z\?\-]+\(/ && /[\w\d\-\_]+\s+[\w\d\-\_]+$/){
     err(30,$_);
 }

 if (/\(\'\'/){  #sem lema
     err(31,$_);
 }

 if (/\'\'\'/ && !/\'\'\s*$/){ #Caso especifico dos segundos
     err(32,$_);
 }

 if (/^[^\/]+\[[\+-]\d\]/){
     err(33,$_);
 }

 if (/:/ && !/^C[PF]/ && ( /\(/ xor /\)/)){
     err(34,$_);
 }

 if ($palant=~/^\s+$/ && /^=/){
     err(35,$palant,$_);
 }



 $nivelant=$nivel;
 $palant = $_;
 $pass=0;
}

######### Estatisticas ###########
my $soma;
my $bugs;
my $BUGS;

open($BUGS, ">$stat") or die "\nNão foi possível escrever o ficheiro das estatísticas!\n";
$bugs="#"x79;
my $ff = $ARGV;
$ff=~s/.+\/([^\/]+)$/$1/;
$bugs.="#\n##Estatísticas para os possíveis erros no $ff, gerado em ".((gmtime)[3])."/".((gmtime)[4]+1)."/".(1900+(gmtime)[5])."\n#\n";
foreach (sort keys (%erros)){
     $bugs.="#$serros[$_] : $erros{$_}\n";
     $soma+=$erros{$_};
}

$bugs.="#\n#Numero total de possíveis erros : $soma\n";
$bugs.="#"x79;
$bugs.="#-";
$bugs.="\n";

print {$BUGS} $bugs;

close($BUGS);
##################################


sub err{
    my ($x,$a,$b)=@_;
    return if ($pass);
    $x-=1;
    my $m=$serros[$x];
    $m=~s/T\d+\)//;
    print "\n\nT".($x+1).":($tn):$.: $m\n" ;
    print &to_html($a)."\n";
    print &to_html($b)."\n" if (defined($b));
    $erros{$x}++;
    $pass=1;
}

sub t{  $_[0] =~ m/\)\t/ }    ### terminal -- palavra
#sub p{ $_[0] !~ m/\:/ && $_[0] =~ /./  && $_[0] !~ /\w/  } ### pontuaçao
sub p{ $_[0] =~ m/<sic/ or $_[0] =~ /./  && $_[0] !~ /\w/  } ### pontuaçao

#procura etiquetas extra duplicadas
sub duplic{
    ($_)=@_;
    my $a;my $b;my $c;my $d;my $v;
    if ( /\([^<>]*<([^<>]+)>(.*)\)/ ){
	$a=$1;
	$v=$2;
        if ( $v=~/[^<>]*<([^<>]+)>(.*)/){
		$b=$1;
		$v=$2;
		if ( $v=~/[^<>]*<([^<>]+)>(.*)/ ){
		    $c=$1;
		    $v=$2;
		    if ($v=~/[^<>]*<([^<>]+)>.*/ ){
			$d=$1;
			return 1 if ($a eq $b || $a eq $c || $a eq $d || $b eq $c || $b eq $d || $c eq $d);
		    }else{
		    return 1 if ($a eq $b || $a eq $c || $b eq $c);
		    }
		}else{
		    return 1 if ($a eq $b);

		}
	    }
    }
    return 0;
}

sub to_html{
    ($_)=@_;
    return $_ if (/&lt;/ || /&gt;/ || /&amp;/); #Evita repeticoes de formatacao para a mesma linha
    s/&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    return $_;
}