#!/usr/bin/perl 

use Data::Dumper;

=head1 aps

 aps: regraAt x pal-set -> pal-set

Aplica uma regra atomica a um conjunto de palavras.

=cut

sub aps{
  my($r,@pal)=@_;
  my @r=();
  my $fi="$r->[0]$r->[1]";
  $fi =~ s/(.)/[.$1]/g;
  @r = map {if (s/$fi$/$r->[0]$r->[1]/i){ s/$r->[1]$/$r->[2]/i;$_ } 
            else {()};} @pal;
}

=head1 ap

 ap: regra x pal-set -> pal-set

 regra = u(regra)   - dá a primeira aplicação possivel
       | a(regra)   - dá o conjunto de todas as aplicações possiveis
       | c(regra)   - dá a composição dos conjuntos
       | regraAt    - regra atomica

Aplica uma regra estruturada a um conjunto de palavras.

=cut

sub ap{
  my($r,@pal)=@_;
  my @r=();
  if   (ref($r) eq "u"){
    @r = grep (/./, map { aps($_,@pal) } @$r);
    @r = (@r[0]);
  }
  elsif(ref($r) eq "a"){
    @r = map { ap($_,@pal) } @$r;
  }
  elsif(ref($r) eq "c"){
    @r=@pal;
    for(@$r){
      @r=grep(/./,ap($_,@r) );
    } 
  }
  else  {@r= ( aps($r,@pal))}
  @r;
}


=head1 prefixos

 prefixos: regra -> pal-set

calcula os sufixos de entrada associada a uma regra.

=cut


sub prefixos{
  my($r)=@_;
  my @r=();
  if   (ref($r) eq "u"){
    @r = map { $_->[0].$_->[1] } @$r;
  }
  elsif(ref($r) eq "a"){
    @r = map { prefixos($_) } @$r;
  }
  elsif(ref($r) eq "c"){
    @r = prefixos($r->[0]) ;
  }
  else  {
    @r= ( $r->[0].$r->[1]  )
  }
  @r;
}

=head1 concatenacao de regras:

  regraqs = regraAt | regraU

  conc: regra -> regrads-set
  dado um esquema da um conjunto de regras simples equivalente

  concaux - concatena regras simples
  concaux: regraAt x regraAt -> regraAt|()

  concsets: regraqs-set  x  regraqs-set  ->  regraqs-set  
  concsets - concatena conjuntos de regrasqs

  concsetsaux: regraqs x regraqs -> regraqs|()

  aps1  - dada uma regra simples calcula a informacao minima das 
        palavras entrada, saida

=cut

sub aps1{
  my($r,$pal)=@_;
  my @r=();
  my $fi="$r->[0]$r->[1]";
  $fi =~ s/(.)/[.$1]/g;
  my $p =$pal;
  if ( $p =~ s/$fi$/$r->[0]$r->[1]/i){
            $pal=$p;
            $pal =~ s/$r->[1]$/$r->[2]/i;
            @r=($p,$pal) } 
  @r;
}

sub concaux{
  my($r1,$r2)=@_;
  my ($p1,$p2,$p3,$p4)=("...........","","","");
  ($p1,$p2)=aps1($r1,$p1);
  return ()  unless $p2;
  ($p3,$p4)=aps1($r2,$p2);
  return ()  unless $p4;
  print "$p1/$p2/$p3/$p4\n";

  $p1 =~ s/\.//g;
  $p2 =~ s/\.//g;
  $p3 =~ s/\.//g;
  $p4 =~ s/\.//g;

  $p3 =~ s/$p2$// if $p2 ;
  $p1 = $p3 . $p1;

  for (reverse( (1..length($p4)))){
    if (substr($p1,0,$_) eq substr($p4,0,$_)) { 
           return [substr($p1,0,$_),substr($p1,$_),substr($p4,$_),{%{$r1->[3]},%{$r2->[3]}}]}
  }
  ["",$p1,$p4,{%{$r1->[3]},%{$r2->[3]}}]; 
}


sub conc{
  my $r=shift;
  my @a="";
  if   (ref($r) eq "u"){
    @a=($r);
  }
  elsif(ref($r) eq "a"){
    @a = ( map { conc($_) } @$r);
  }
  elsif(ref($r) eq "c"){
    my ($l1,@l)=@$r;
    @a= ( conc($l1)) ;

    for(@l){
      @a=(grep(defined($_),(concsets([@a],[conc($_)]))));
#      @a=                 (concsets([@a],[conc($_)]));
    } 
  }
  elsif(ref($r)){ @a= ($r)}
  else {@a=()}
  @a;
}

sub concsets{
  my ($r1,$r2)=@_;
  my $aux;
  map { $aux = $_; ( map {concsetsaux($aux,$_) } @$r2 ) } @$r1 ; 
} 

sub concsetsaux{
  my ($r1,$r2)=@_;
  my $aux;
  my @a=();
  if(ref($r1) eq "u" && ref($r2) eq "u"){
     @a = (map { $aux = $_; ( map {concaux($aux,$_) } @$r2 ) } @$r1) ; 
     if(scalar @a >=2 ) {u(@a)} else {@a} 
  }
  elsif(ref($r1) eq "u"){
     @a = (map {concaux($_,$r2) } @$r1) ; 
     if(scalar @a >=2 ) {u(@a)} else {@a} 
  }
  elsif(ref($r2) eq "u"){
     @a = (map {concaux($r1,$_) } @$r2) ; 
     if(scalar @a >=2 ) {u(@a)} else {@a} 
  }
  else{
     concaux($r1,$r2); 
  }
} 

# exemplos

$p=u(                    # plural
     ["","ão","ões",{n=>'p'}],
     ["r","","es",{n=>'p'}],
     ["","","s",{n=>'p'}],
    );

$pn=a(
     ["","","",{n=>'s',p=>'1'}],
     ["","","s",{n=>'s',p=>'2'}],
     ["","","",{n=>'s',p=>'3'}],
     ["","","mos",{n=>'p',p=>'1'}],
     ["","a","eis",{n=>'p',p=>'2'}],
     ["","e","eis",{n=>'p',p=>'2'}],
     ["i","","eis",{n=>'p',p=>'2'}],
     ["","","m",{n=>'p',p=>'3'}],
     );

$id=["","","",{}];                       # identidade

$f=u(["","o","a",{g=>'f'}],              # feminino
     ["or","","a",{g=>'f'}],
     ["","ão","ona",{g=>'f'}],
    );

$GN = a( $id,                            # genero numero
         $f,
         $p,
         c($f,$p)
       );

$pp=c(a(["","er","ido",{tempo=>'pp'}],   #participio passado
        ["a","r","do",{tempo=>'pp'}], 
        ["i","r","do",{tempo=>'pp'}]), 
      $GN);

$verbo=
 c(["","","",{cat=>'v'}],
    a(                                   #verbos
    c(u(                                        # imperfeito do indicativo
         ["a","r","va",{tempo=>'imperfInd'}],
         ["","er","ia",{tempo=>'imperfInd'}],
         ["i","r","a", {tempo=>'imperfInd'}]),
      $pn),
    c(["r","","a",   {tempo=>'maisqueperfInd'}],# mais-que-perfeito do ind
      $pn),
    c(["","r","sse", {tempo=>'imperfConj'}],    # imperfeito do conjuntivo
      $pn),
    c(["r","","ia",  {tempo=>'condicional'}],   # condicional
      $pn),
    $pp));                                      # participio

$verboizar=
  c(u( 
#        ["a","","tizar",{sem=>"izar"}],
#        ["","e","izar",{sem=>"izar"}],
         ["","o","izar",{sem=>"izar"}],
#        ["","avel","abilizar",{sem=>"izar"}],
#       ["l","","izar",{sem=>"izar"}],
#       ["r","","izar",{sem=>"izar"}],
    ),
     $verbo
   );

#print Dumper(concaux( ["a","r","va",{n=>'p'}],["","","s",{n=>'p'}]));
#print Dumper(concaux( ["a","r","va",{n=>'p'}],["ia","va","bas",{n=>'p'}]));
#print Dumper(concsets([["a","r","va",{n=>'p'}]],[["ia","va","bas",{n=>'p'}]]));
#print Dumper(conc( ["a","r","va",{n=>'p'}]));
#print Dumper(conc( u( ["a","r","va",{n=>'p'}],["ia","va","bas",{n=>'p'}])));
#print Dumper(conc( a( ["a","r","va",{n=>'p'}],["ia","va","bas",{n=>'p'}])));
#print Dumper(conc( c( ["a","r","va",{n=>'p'}],["ia","va","bas",{n=>'p'}])));
#print Dumper(conc( c( ["a","r","va",{n=>'p'}],a(["ia","va","bas",{n=>'p'}],["","","qqq",{n=>'p'}]))));
#print Dumper(conc($pp));
#print Dumper(conc($verbo));
#print Dumper(conc($verboizar));
PP(conc($verboizar));

sub PP{
 for my $a (@_){
   my $x= Dumper($a->[3]);
   $x =~ s/.*?=\s*//;
   $x =~ s/=>/=/g;
   $x =~ s/\s+//g;
   $x =~ s/'//g;
   if ($a->[1]){ print "$a->[0]$a->[1] : -$a->[1],$a->[2] ;$x\n" }
   else        { print "$a->[0] : $a->[2] ;$x\n" }
 };

}


sub u {bless([@_],"u");}
sub a {bless([@_],"a");}
sub c {bless([@_],"c");}

#print Dumper($GN);
print join("...", ap($GN,"lindo"))," (GN(lindo))\n" ; 
#print join("...", ap($p,"lindo"))," (p(lindo))\n" ; 
#print join("...", ap($p,"leão"))," (p(leão))\n" ; 
#print join("...", ap($verbo,"lavar"))," (verbo(lavar))\n" ; 
#print join("...",prefixos($verbo));

#print "-" x 20, "\n";
while(<>){
  chop;
  if(/(\w+)\s*\+\s*(\w+)/){
     print join("...", ap(eval("\$$1"),$1))," ($2($1))\n" ; A }
  else {
     print join("...", ap("verbo",$_))," (verbo($_))\n" ; 
  }
}
__DATA__