package pln;

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

require Exporter;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
getPN	
forPN
);
$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 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.1 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 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__
# Below is the stub of documentation for your module. You better edit it!

=head1 NAME

pln - Perl extension for simple natural language processing

=head1 SYNOPSIS

  use pln;
  getPN;

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

=head1 DESCRIPTION

=head2 C<forPN( $funref )>

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

=head1 AUTHOR

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

=head1 SEE ALSO

perl(1).

=cut