package pt::pln;

#use strict;
#use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter AutoLoader);
@EXPORT = qw(

   getPN	
   printPN	
   printPNstring
   forPN
   forPNstring

   syllabe
   accent
   wordaccent

   sentences

   cqptokens
);
$VERSION = '0.01';

# printPN  - extrai os nomes próprios dum texto.
#   -comp    junta certos nomes: Fermat + Pierre de Fermat = (Pierre de) Fermat
#   -prof
#   -e       "Sebastiao e Silva" "e" como pertencente a PN
#   -em     "em Famalicão" como pertencente a PN
use locale;

my ($conso, $vogal);
BEGIN{

$conso='[bcdfghjklmnpkrstvwyxzç]';
$vogal='[áéíóúôâêãõàaeiou]';

$/ = "";           # input record separator=1 or more empty lines

$np1='(?:[A-ZÉÚÓÁÂ][.]|[sS]r[.]|[dD]r[.]|St[oa]?[.]|[A-ZÉÚÓÁÂ]\w+(?:-\w+)*)';

if ($e){ 
  $np="$np1(?:\\s+(?:d[eao]s?\\s+|e\\s+)?$np1)*|(?:[«\x93].{1,40}?[»\x94])";}
else { $
  np="$np1(?:\\s+(?:d[eao]s?\\s+)?$np1)*|(?:[«\x93].{1,40}?[»\x94])";}

@stopw= qw{
no com se em segundo a o os as na nos nas do das dos da tanto 
para de desde mas quando esta sem nem só apenas mesmo até uma uns um
pela por pelo pelas pelos depois ao sobre como umas já enquanto aos
também amanhã ontem embora essa nesse olhe 
primeiro simplesmente era foi é será são seja
chama-se chamam-se subtitui resta diz salvo disse diz
};

$prof=join("|", qw{
astrólogo
astrónomo
advogado
cantor
actor
baterista
compositor
dramaturgo
engenheiro
escritor
filósofo
flautista
físico
investigador
matemático
médico
ministro
músico
químico
pianista
poeta
professor
teólogo
jogador
});

$adje=join("|", qw{
português
francês
inglês
espanhol
internacional
bracarence
minhoto
});

$sep1=join("|", qw{
chamado
"conhecido como"
});

$sep2=join("|", qw{
brilhante
conhecido
reputado
popular
});

@vazia{@stopw}=(@stopw);    #para ser mais facil ver se uma pal 'e vazia
$em = '\b(?:[Ee]m|[nN][oa]s?)';
}

sub forPN{
  my $f=shift;
  die("invalid parameter") unless (ref($f) eq "CODE");
  while (<>) {
     $ctx=$_; 
     s/(\w+\s+|[«»,()'`i"]\s*)($np)/$1 . &{$f}($2,$ctx)/ge       ;
     print; 
  }
}

sub forPNstring{
  my $f=shift;
  die("invalid parameter: function expected") unless (ref($f) eq "CODE");
  my $text = shift;
  my $sep = shift || "\n";
  my $r = '';
  for (split(/$sep/,$text)){
     $ctx=$_; 
     s/(\w+\s+|[«»,()'`i"]\s*)($np)/$1 . &{$f}($2,$ctx)/ge       ;
     $r .= "$_$sep";
  }
  $r;
}

sub printPNstring{
  my $text = shift;
  my %opt;
  @opt{@_} = @_;
  my (%profissao,%names,%namesduv);

  for($text){
    chop;
    s/\n/ /g;
    for (/[.?!:;"]\s+($np1\s+$np)/gxs)     { $namesduv{$_}++;}
    for (/[)>(«]\s*($np1\s+$np)/gxs)       { $namesduv{$_}++;}
    for (/(?:[\w«»,]\s+)($np)/gxs)         { $names{$_}++;}
    if ($opt{em}) { for (/$em\s+($npxs)/g) { $gnames{$_}++;}}
    if ($opt{prof}) { 
       while(/\b($prof)\s+(?:(?:$sep1)\s+)?($np)/g)   {$profissao{$2}=$1;}
       while(/(?:[\w«»,]\s+|[(])($np),\s*(?:(?:$sep2)\s+)?($prof)/g) 
            {$profissao{$1}=$2;}
    }
  }

  #tratamento dos nomes "duvidosos" = Nome prop no inicio duma frase
  #
  
  for (keys %namesduv){
     if(/^(\w+)/ && $vazia{lc($1)} )   #exemplo "Como Jose Manuel"
        { s/^\w+\s*//;                  # retira-se a 1.a palavra
          $names{$_}++;}
     else 
        { $names{$_}++;}
  }
  if($opt{oco}){
       for (sort {$names{$b} <=> $names{$a}} keys %names )
           {printf("%60s - %d\n", $_ ,$names{$_});} 
  }
  else{ if($opt{comp}){my @l = sort compara keys %names;
                       compacta(@l); }
        else{for (sort compara keys %names )    
               {printf("%60s - %d\n", $_ ,$names{$_});} }
  
        if($opt{prof}){print "\nProfissões\n";
             for (keys %profissao){print "$_ -- $profissao{$_}";} }

        if($opt{em}){print "\nGeograficos\n";
            for (sort compara keys %gnames )    
               {printf("%60s - %d\n", $_ ,$gnames{$_});} }
  }
}

sub getPN{
  my %opt;
  @opt{@_} = @_;
  my (%profissao,%names,%namesduv);
  while (<>) {
    chop;
    s/\n/ /g;
    for (/[.?!:;"]\s+($np1\s+$np)/g)     { $namesduv{$_}++;}
    for (/[)>(«]\s*($np1\s+$np)/g)       { $namesduv{$_}++;}
    for (/(?:[\w«»,]\s+)($np)/g)         { $names{$_}++;}
    if ($opt{em}) { for (/$em\s+($np)/g) { $gnames{$_}++;}}
    if ($opt{prof}) { 
       while(/\b($prof)\s+(?:(?:$sep1)\s+)?($np)/g)   {$profissao{$2}=$1;}
       while(/(?:[\w«»,]\s+|[(])($np),\s*(?:(?:$sep2)\s+)?($prof)/g) 
            {$profissao{$1}=$2;}
    }
  }

  #tratamento dos nomes "duvidosos" = Nome prop no inicio duma frase
  #
  
  for (keys %namesduv){
     if(/^(\w+)/ && $vazia{lc($1)} )    # exemplo "Como Jose Manuel"
        { s/^\w+\s*//;                  # retira-se a 1.a palavra
          $names{$_}++;}
     else 
        { $names{$_}++;}
  }
  (%names)
}

sub printPN{
  my %opt;
  @opt{@_} = @_;
  my (%profissao,%names,%namesduv);
  
  while (<>) {
    chop;
    s/\n/ /g;
    for (/[.?!:;"]\s+($np1\s+$np)/g)     { $namesduv{$_}++;}
    for (/[)>(«]\s*($np1\s+$np)/g)       { $namesduv{$_}++;}
    for (/(?:[\w«»,]\s+)($np)/g)         { $names{$_}++;}
    if ($opt{em}) { for (/$em\s+($np)/g) { $gnames{$_}++;}}
    if ($opt{prof}) { 
       while(/\b($prof)\s+(?:(?:$sep1)\s+)?($np)/g)   {$profissao{$2}=$1;}
       while(/(?:[\w«»,]\s+|[(])($np),\s*(?:(?:$sep2)\s+)?($prof)/g) 
            {$profissao{$1}=$2;}
    }
  }

  #tratamento dos nomes "duvidosos" = Nome prop no inicio duma frase
  #
  
  for (keys %namesduv){
     if(/^(\w+)/ && $vazia{lc($1)} )   #exemplo "Como Jose Manuel"
        {s/^\w+\s*//;                  # retira-se a 1.a palavra
         $names{$_}++;}
     else 
        { $names{$_}++;}
  }

  if($opt{oco}){
       for (sort {$names{$b} <=> $names{$a}} keys %names )
           {printf("%6d - %s\n",$names{$_}, $_ );} 
  }
  else{ if($opt{comp}){my @l = sort compara keys %names;
                       compacta(@l); }
        else{for (sort compara keys %names )    
               {printf("%60s - %d\n", $_ ,$names{$_});} }
  
        if($opt{prof}){print "\nProfissões\n";
             for (keys %profissao){print "$_ -- $profissao{$_}";} }

        if($opt{em}){print "\nGeograficos\n";
            for (sort compara keys %gnames )    
               {printf("%60s - %d\n", $_ ,$gnames{$_});} }
  }
}

sub accent{
  my $p=shift;
  $p =~ s/(\w+)/ wordaccent($1) /ge;
  $p
}

sub wordaccent{
  my $p=syllabe(shift);
  for ($p){
    s/(\w*[áéíóúôâêãõ])/"$1/  or           # word with an accent character
    s/(\w*([zlr]|[iu]s?))$/"$1/  or        # word ending with z l r i u is us
    s/(\w+\|\w+)$/"$1/  or                 # accent in 2 syllabe frm the end
    s/(\w)/"$1/;                           # accent in the only syllabe

    s/"(($conso)*($vogal))/$1:/;
    
  }
  $p
}

my %syl = (  
 20 => " -.!?:;",
 10 => "bçdfgjkpqtv",
 7 => "sc",
 6 => "m",
 5 => "rnlzx",
 4 => "h",
 3 => "wy",
 2 => "eaoáéíóúôâêãõ",
 1 => "iu",
 breakpair => "ie|ia|io|ee|oo|oa|sl|sm|sn|sc|rn",
);

my %sylpri = ();
for my $pri (grep(/\d/, keys %syl)){ 
   for(split(//,$syl{$pri})) { $sylpri{$_} = $pri}}

(my $sylseppair= $syl{breakpair}) =~ s/(\w)(\w)/(\?<=($1))(\?=($2))/g;

sub syllabe{
  my $p=shift;

  for($p){ 
    s/$sylseppair/|/g; 
    s{(\w)(?=(\w)(\w))}
     { if(     $sylpri{lc($1)} < $sylpri{lc($2)} 
            && $sylpri{lc($2)} >= $sylpri{lc($3)} ) {"$1|"}
       else{$1}
     }ge;
  }
  $p
}

sub compara{     # ordena pela lista de palavras invertida
 join(" ", reverse(split(" ",$a))) cmp join(" ", reverse(split(" ",$b)));
}

sub compacta{
   my $p = shift;
   my $r = $p;
   my $q = $names{$p};
   while ($s = shift)
     { if ($s =~ (/^(.+) $p/)) { $r = "($1) $r" ; 
                                 $q += $names{$s};
                               }
       else {print "$r - $q"; $r=$s; $q = $names{$s}; }
       $p=$s;
     }
   print "$r - $q";
}

my %savit_p = ();
my $savit_n = 0;

my $terminador='([.?!;:]+[»]?|<[pP]>|<br>)';

my $protect = '
       [\w_.-]+ \@ [\w_.-]+                      # emails
    |  <[^>]*>                                   # marcup XML SGML
    |  \d+\.\d+                                  # numbers
    |  \d+\:\d+                                  # the time
    |  ((https?|ftp|gopher)://|www)[\w_./~-]+    # urls
';

my $abrev = join '|', qw( srt?a? dra? [A-Z] etc exa? jr profs? arq av estr?
    et al vol eng tv lgo pr Oliv ig mrs? min rep );

sub sentences{
  my $par=shift;
  for($par){
      s/($protect)/savit($1)/xge;
      s#\b(($abrev)\.)#savit($1)#ige;
      s#($terminador)#$1</s>\n<s>#g;
      $_=loadit($_);
      s#<s>\s*$##s;
  }
  "<s>$par";
}
  
sub cqptokens{
  local $/ = ">";
  while(<>) {
        s/($protect)/savit($1)/xge;
	s#([»\]])#$1 #g;
	s#([«\[])# $1#g;
	s#\"# \" #g;
 	s/(\s*\b\s*|\s+)/\n/g;
	s/(.)\n-\n/$1-/g;
	s/\n+/\n/g;
	s/\n(\.?[ºª])\b/$1/g;
	while ( s#\b([0-9]+)\n([\,.])\n([0-9]+\n)#$1$2$3#g ){};
	s#\n($abrev)\n\.\n#\n$1\.\n#ig;
        s/\n?</\n</;
        $_=loadit($_);
	print;
  }
}

sub savit{
  my $a=shift; 
  $savit_p{++$savit_n}=$a ;
  " __MARCA__$savit_n " 
}

sub loadit{
  my $a = shift; 
  $a =~ s/ ?__MARCA__(\d+) ?/$savit_p{$1}/g;
  $savit_n = 0;
  $a;
}

1;


=head1 DESCRIPTION

perl(1).

cqp(1)

=cut      

__END__


$lm='[a-záéíóúâêôàãõçüöñ]';                      # letra minuscula
$lM='[A-ZÁÉÍÓÚÂÊÔÀÃÕÇÜÖÑ]';                      # letra Maiuscula
$l1='[A-ZÁÉÍÓÚÂÊÔÀÃÕÇÜÖÑa-záéíóúâêôàãõçüöñ0-9]'; # letra e numero
$c1='[^»a-záéíóúâêà,;?!)]';


=head1 NAME

pln - Perl extension for simple natural language processing, portuguese language

=head1 SYNOPSIS

  use pln;

  printPN(@options);

  printPNstring($textstrint, @options);

  forPN(sub{my ($pn, $contex)=@_;... } ) ;

  forPNstring(sub{my ($pn, $contex)=@_;... } ,$textstring, regsep) ;

  $st = syllabe($phrase);

  $s = accent($phrase); 

  $s = wordaccent($word); 

  $s = sentences($textstring); 

  perl -Mptpln -e cqptokens file* > out
  

=head1 DESCRIPTION

=head2 C<forPN( $funref )>

Substitutes all C<propername> by C<funref(propername)> in STDIN and sends
output to STDOUT

=head2 C<forPNstring( $funref, "textstring" [, regSeparator] )>

Substitutes all C<propername> by C<funref(propername)> in the text string.

=head2 C<syllabe( $phrase )>

Returns the phrase with the syllabes separated by "|"

=head2 C<accent( $phrase )>

Returns the phrase with the syllabes separated by "|" and accents marked with
the charater ".

=head2 C<cqptokens()>

cpqtokens - encodes a text from STDIN for CQP (one token per line)

=head1 AUTHOR

José João Almeida (jj@di.uminho.pt)

Paulo Rocha, paulo.rocha@alfa.di.uminho.pt

=head1 SEE ALSO

perl(1).

cqp(1).

=cut
