package pln;

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

require Exporter;

@ISA = qw(Exporter AutoLoader);
@EXPORT = qw(
   getPN	
   forPN
   forPNf
   syllabe
   accent
   wordaccent
);
$VERSION = '0.01';

# getPN  - 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;

BEGIN{
# $, = ' ';               # set output field separator
# $\ = "\n";              # set output record separator

$/ = "";                # set 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
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 forPNf{
  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 getPNf{
  my $text = shift;
  my %opt  = @_;

  for($text){
    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{$_}++;}}
  }

  #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{comp}){my @l = sort compara keys %names;
            compacta(@l);
           }
  else{for (sort compara keys %names )    
           {printf("%60s - %d\n", $_ ,$names{$_});}
      }
  
  if($em){print "Geograficos\n";
      for (sort compara keys %gnames )    
           {printf("%60s - %d\n", $_ ,$gnames{$_});}
  }
}


sub getPN{

  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 ($em) { for (/$em\s+($np)/g)      { $gnames{$_}++;}}
    if ($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($comp){my @l = sort compara keys %names;
            compacta(@l);
           }
  else{for (sort compara keys %names )    
           {printf("%60s - %d\n", $_ ,$names{$_});}
      }
  
  if($prof){
     for (keys %profissao){print "$_ -- $profissao{$_}";}
  }
  
  if($em){print "Geograficos\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
  }
  $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";
}

1;
__END__

=head1 NAME

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

=head1 SYNOPSIS

  use pln;

  getPN;

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

  $st = syllabe($phrase);

  $s = accent($phrase); 

  $s = wordaccent($word); 


=head1 DESCRIPTION

=head2 C<forPN( $funref )>

Substitutes all C<propername> by C<funref(propername)>

=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 ".

=head1 AUTHOR

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

=head1 SEE ALSO

perl(1).

=cut