#!/usr/bin/perl
use strict;

my ($min,$max) = (5,7);

my $char = "[a-zA-ZñâêîôûãõáéíóúàèìòùäëïöüçÂÊÎÔÛÃÕÁÉÍÓÚÀÈÌÒÙÄËÏÖÜÇ]";
my @def = qw(IDE PRO INI         SXS TAM                 PXP PPP ITT);
my @all = qw(IDE PRO INI ANA SEQ SXS TAM TER I&E I&T T&T PXP PPP ITT);
my @force = qw(IDE);
my @forbid = qw();

my %min = ('INI' => 1, 'SEQ' => 3, 'TAM' => 2, 'TER' => 1);
my %max = ('INI' => 6, 'SEQ' => 6, 'TAM' => 6, 'TER' => 6);
#IDE -> Identidade
#PRO -> Propriedades
#INI -> Iniciais
#ANA -> Anagramas
#SEQ -> Sequências
#TAM -> Tamanhos
#TER -> Terminais

#I&E -> Iniciais e Terminais
#I&T -> Iniciais e Tamanhos
#T&T -> Tamanhos e Terminais
#ITT -> Iniciais, Tamanhos e Terminais

#SXS -> Sequências combinadas 2 vezes	!!!!!!!!!! ainda não está implementado
#PXP -> Propriedades combinadas 2 vezes
#PPP -> Propriedades combinadas 3 vezes

my (%values,%properties,%props,%op);

for my $tema (<sources/*>)
{
  my $tema2 = $tema;
  $tema2 =~ s!^sources/!!;
  $tema2 =~ s!/.*!!;
  $tema2 =~ y/_/ /;

  print "processing '$tema2'"."."x(20-length($tema2))."....";

  my $done = 1;
  my $date = -M "$tema2.dat2";
  for (<$tema/*.lst>) {-M $_ < $date && ($done = 0)}
  $done = 0 unless -e "$tema2.dat2";
  if ($done)
  {
    print "UPTODATE\n";
    next
  }

  my @topics;

  for my $topico (<$tema/*.lst>)
  {
    my @list_temp = grep {! /^#/} split(/\n/,`cat "$topico"`);
    my $st = 0;
    %op = ();

#    my ($st,@list_temp,%op) = (0,grep {! /^#/} split(/\n/,`cat "$topico"`));

    for (split(/\|/,substr($list_temp[0] =~ /^{(.*)}$/ ? shift @list_temp : "{DEF}",1,-1)))
    {
      my $st = $st ? 0 : 1;
      for (split(/\s+/,$_))
      {
        if ($_ eq 'ALL') {for (@all) {$op{$_} = $st}}
        elsif ($_ eq 'DEF') {for (@def) {$op{$_} = $st}}
        else {$op{$_} = $st}
      }
    }
    for (@force) {$op{$_} = 1}
    for (@forbid) {$op{$_} = 0}

    $topico =~ s!^$tema/!!;
    $topico =~ s!-(.)\.lst!!;
    my $a = $1;
    $topico =~ s/_/ /g;

#    print "\n\t$topico:\n\t\t";

    my @list;
    %values = %properties = %props = ();

    for (@list_temp)
    {
      /^(.*?)(?: \((.*)\))?(?: -- (.*))?$/ || die ("Erro em $topico: '$_'\n");
      die ("Erro:'$1' repetido em '$topico'\n") if defined $values{$1};
      $values{$1} = "$1" . ($2 ? " ($2)" : "");
      push @list, $1;
      $properties{$1} = $3;
      for (map {/(.*) \(.*\)/ ? $1 : $_} split(/\|/,$properties{$1})) {$props{$_}++}  # ja estamos a remover a informação adicional das propriedades.. falta utilizá-la
    }

### identidade ###
#my $mark = 'IDE';

    if ($op{'IDE'}) {push @topics, "$topico\n".(join("\n",vals(@list))) if (ok(scalar @list))}
#    if ($op{'IDE'}) {print "IDE"} else {print "   "}

### propriedades ###
#$mark = 'PRO';

    if ($op{'PRO'} || $op{'PXP'} || $op{'PPP'})
    {
      for my $p (keys %props)
      {
        my @props = grep {matchwith($p,split(/\|/,$properties{$_}))} @list;
        if ($op{'PRO'} && ok($props{$p}))
        {
          push @topics, "$topico $p\n" . join("\n",vals(@props))
        }
        if ($op{'PXP'} || $op{'PPP'})
        {
          for my $p2 (grep {$p gt $_} keys %props)
          {
            my @props2 = (grep {matchwith($p2,split(/\|/,$properties{$_}))} @props);
            if (enough ($props{$p}))
            {
              push @topics, "$topico $p, $p2\n" . join("\n",vals(@props2)) if (ok(scalar @props2) && $op{'PXP'});
              if ($op{'PPP'})
              {
                for my $p3 (grep {$p2 gt $_} keys %props)
                {
                  my @props3 = (grep {matchwith($p3,split(/\|/,$properties{$_}))} @props2);
                  push @topics, "$topico $p, $p2, $p3\n" . join("\n",vals(@props3)) if (ok(scalar @props3))
                }
              }
            }
          }
        }
      }
    }
#    if ($op{'PRO'}) {print " PRO"} else {print "    "}
#    if ($op{'PXP'}) {print " PXP"} else {print "    "}
#    if ($op{'PPP'}) {print " PPP"} else {print "    "}

### tamanhos ###
#$mark = 'TAM';

    if ($op{'TAM'})
    {
      my %tamanhos;
      for (@list) {$tamanhos{charlength($_)}++}
      for my $t (keys %tamanhos)
      {
        next unless ($min{'TAM'} <= $t && $t <= $max{'TAM'});
        if (ok($tamanhos{$t}))
        {
          push @topics, "$topico com $t letras\n" . join("\n",vals(grep {charlength($_) == $t} @list))
        }
      }
    }
#    if ($op{'TAM'}) {print " TAM"} else {print "    "}

### iniciais ###
#$mark = 'INI';

    if ($op{'INI'})
    {
      for my $n ($min{'INI'}..$max{'INI'})
      {
        my %iniciais;
        for (@list) {/^(($char){$n})/ && $iniciais{$1}++}
        for my $l (keys %iniciais)
        {
          if (ok($iniciais{$l}))
          {
            push @topics, "$topico começad${a}s por '$l'\n" . join("\n",vals(grep {/^$l/} @list))
          }
        }
      }
    }
#    if ($op{'INI'}) {print " INI"} else {print "    "}

### sequências ###
#$mark = 'SEQ';

    if ($op{'SEQ'})
    {
      for my $n ($min{'SEQ'}..$max{'SEQ'})
      {
        my %seqs;
        for (@list)
        {
          my @l = split(//,$_);
          while (@l >= $n)
          {
            my $t = join("",@l[0..$n-1]);
            shift @l;
            $seqs{$t}++ if $t =~ /^$char*$/
          }
        }
        for my $l (keys %seqs)
        {
          if (ok($seqs{$l}))
          {
            push @topics, "$topico com a sequência '$l'\n" . join("\n",grep {/$l/} @list);
          }
        }
      }
    }
#    if ($op{'SEQ'}) {print " SEQ"} else {print "    "}
#    if ($op{'SXS'}) {print " SXS"} else {print "    "}

### terminais ###
#$mark = 'TER';

    if ($op{'TER'})
    {
      for my $n ($min{'TER'}..$max{'TER'})
      {
        my %term;
        for (@list) {/(($char){$n}$)/ && $term{$1}++}
        for my $l (keys %term)
        {
          if (ok($term{$l}))
          {
            push @topics, "$topico terminad${a}s em '$l'\n" . join("\n",vals(grep {/$l$/} @list))
          }
        }
      }
    }
#    if ($op{'TER'}) {print " TER"} else {print "    "}

### iniciais e terminais combinados ###
#$mark = 'I&E';

    if ($op{'I&E'})
    {
      for my $ni ($min{'INI'}..$max{'INI'})
      {
        my %iniciais;
        for (@list) {/^(($char){$ni})/ && $iniciais{$1}++}
        for my $in (keys %iniciais)
        {
          my @in = grep {/^$in/} @list;
          next unless @in >= $min;
          for my $nt (($min{'TER'}+1)..$max{'TER'})
          {
            my %terminais;
            for (@in) {/(($char){$nt})$/ && $terminais{$1}++}
            for my $te (keys %terminais)
            {
              if (ok($terminais{$te}))
              {
                push @topics, "$topico começad${a}s por '$in', terminad${a}s em '$te'\n" . join("\n",vals(grep {/$te$/} @in))
              }
            }
          }
        }
      }
    }
#    if ($op{'I&E'}) {print " I&E"} else {print "    "}

### iniciais e tamanhos combinados ###
#$mark = 'I&T';

    if ($op{'I&T'})
    {
      for my $n ($min{'INI'}..$max{'INI'})
      {
        my %iniciais;
        for (@list) {/^(($char){$n})/ && $iniciais{$1}++}
        for my $in (keys %iniciais)
        {
          my @in = grep {/^$in/} @list;
          next unless @in >= $min;
          my %tamanho;
          for (@in) {$tamanho{charlength($_)}++}
          for my $t (keys %tamanho)
          {
            next unless ($min{'TAM' <= $t && $t <= $max{'TAM'}});
            if (ok($tamanho{$t}))
            {
              push @topics, "$topico começad${a}s por '$in', com $t letras\n" . join("\n",vals(grep {charlength($_) == $t} @in))
            }
          }
        }
      }
    }
#    if ($op{'I&T'}) {print " I&T"} else {print "    "}

### tamanho e terminais combinados ###
#$mark = 'T&T';

    if ($op{'T&T'})
    {
      for my $n ($min{'TER'}..$max{'TER'})
      {
        my %terminais;
        for (@list) {/(($char){$n})$/ && $terminais{$1}++}
        for my $te (keys %terminais)
        {
          my @te = grep {/$te$/} @list;
          next unless @te >= $min;
          my %tamanho;
          for (@te) {$tamanho{charlength($_)}++}
          for my $t (keys %tamanho)
          {
            next unless ($min{'TAM'} <= $t && $t <= $min{'TAM'});
            if (ok($tamanho{$t}))
            {
              push @topics, "$topico terminad${a}s em '$te', com $t letras\n" . join("\n",vals(grep {charlength($_) == $t} @te))
            }
          }
        }
      }
    }
#    if ($op{'T&T'}) {print " T&T"} else {print "    "}

### iniciais, tamanhos e terminais combinados
#$mark = 'ITT'

    if ($op{'ITT'})
    {
      for my $n ($min{'TAM'}..$max{'TAM'})
      {
        my @lt = grep {charlength($_) == $n} @list;
        for my $i ($min{'INI'}..$max{'INI'})
        {
          my %iniciais;
          for (@lt) {/^(($char){$i})/ && $iniciais{$1}++}
          for my $in (keys %iniciais)
          {
            my @lt2 = grep {/^$in/} @lt;
            enough(scalar @lt2) || next;
            for my $t ($min{'TER'}..$max{'TER'})
            {
              my %terminais;
              for (@lt2) {/(($char){$t})$/ && $terminais{$1}++}
              for my $te (keys %terminais)
              {
                if (ok($terminais{$te}))
                  {
                    push @topics, ("$topico começad${a}s por '$in', terminad${a}s em '$te', com $n letras\n" .
                      join("\n",vals(grep {/$te$/} @lt2)))
                  }
              }
            }
          }
        }
      }
    }
#    if ($op{'ITT'}) {print " ITT"} else {print "    "}

### anagramas ###
#$mark = 'ANA';

    if ($op{'ANA'})
    {
      my %anagramas;
      for (@list) {$anagramas{letras($_)}++}
#my ($maior,@anagrama) = (0);
      for my $l (keys %anagramas)
      {
#if ($anagramas{$l} == $maior) {push @anagrama,$l}
#if ($anagramas{$l} > $maior) {$maior = $anagramas{$l};@anagrama = ($l)}
        if (ok($anagramas{$l}))
        {
          print STDERR "TENHO $anagramas{$l} anagramas de '$l' ($topico)\n";
          push @topics, "$topico anagramas de '$l'\n" . join("\n",vals(grep {$l eq letras($_)} @list))
        }
      }
#if ($maior>1) {print "anagramas até $maior em $topico:\n".join("\n",map{my$a=$_;"\t".join(",",grep{$a eq letras($_)}@list)."\n"}@anagrama)}
    }
#    if ($op{'ANA'}) {print " ANA"} else {print "    "}

#    print "\n";

### escrever o ficheiro ###

  }

  if (@topics)
  {
    open (T,">$tema2.dat2") || die ("could not create file $tema2.dat2: $!\n");
    print T join("\n%\n",sort @topics),"\n";
    close (T)
  }

  print "DONE\n";
}

### subrotinas daqui para baixo

sub ok {
  $_[0] >= $min && $_[0] <= $max
}

sub enough {
  $_[0] >= $min
}

sub matchwith {
  for (@_[1..$#_]) {return 1 if /^$_[0]/}
}

#sub matchwith {
#  my $a = shift;
#  for (@_) {return 1 if /^$a/}
#  0
#}

sub vals {
  map {$values{$_}} @_
}

sub charlength {
  scalar grep {/$char/} split //, $_[0]
}

#sub charlength {
#  my ($a,$c) = $_[0];
#  $a =~ s/$char/$c++/ge;
#  $c
#}

sub letras {
  join '', sort split //, $_[0] 
}