package Guesser;
require Exporter;

our @ISA = qw(Exporter);

our $VERSION = 1;
our %EXPORT_TAGS = ('all' => [ qw() ] );
our @EXPORT_OK = (@{$EXPORT_TAGS{'all'}});
our @EXPORT = qw(
  &urls2domain_offsets
  &domain_offsets2blocks
  &blocks2pairs
  &blocks2trios
);

my %tags;
my %invtags;

sub jjtags{ if(@_){ ( @_ , @{ $tags{$_[0]}}) ; } 
            else  { keys (%tags)} }
sub jjnames{ @_ ? (map {$invtags{$_}} @_) :    
                  (map {$invtags{$_}} keys (%tags))  
}

use Lingua::Identify;
#use String::Approx 'adist';
#use Text::Levenshtein qw(distance);

use File::Munger;

use strict;

my ($val_sizes,$val_names,$val_punct,$min_sizes,$min_names,$min_punct);
my ($norm_tags,@val_conts,@min_conts);
my (%conts,%weights,%min_values);

BEGIN {

# tudo o que pode ser usado para comparações
  %conts = (
    HTML => [
      '<[aA]\s*[hH][rR][eE][fF]\s*=\s*"(.*?)"\s*>',
      '<[iI][mM][gG]\s*[sS][rR][cC]\s*=\s*"(.*?)".*?>'],
    Text => [' ([A-Z][a-z]*)','\d+'],
    XML => [' ([A-Z][a-z]*)','\d+','<([^/].*?)>'],

    CGI => [
      '<[aA]\s*[hH][rR][eE][fF]\s*=\s*"(.*?)"\s*>',
      '<[iI][mM][gG]\s*[sS][rR][cC]\s*=\s*"(.*?)".*?>'],
    );

# tags de normalização
  #$norm_tags = Lingua::Identify::give_tags();
  $norm_tags = jjtags();

# pesos das várias heurísticas
  %weights = (    # size, names, punctuation, contents*
    HTML => [10,10,0,10,10],
    Text => [10,10,0,5,10],
    XML => [10,10,0,5,10,10],
    PDF => [1,1,0], ASP => [1,1,0], PS => [1,1,0],

    CGI => [10,10,0,10,10],
    );

# valores percentuais mínimos necessários em cada heurística
  %min_values = ( # size, names, punctuation, contents*
    HTML => [50,0,0,0,0],
    Text => [50,0,10,5,50],
    XML => [50,0,10,5,50,20],
    PDF => [0,0,0], 
    ASP => [0,0,0], 
    PS => [0,0,0],

    CGI => [50,0,0,0,0],
    );
  %tags=(
         pt => [qw{ portuguese portugues português port por pt_pt pt_br }],
         en => [qw{ english ingles inglês eng uk }],
         fr => [qw{ french francais français frances francês }],
         es => [qw{ spanish espanol espanhol sp spa }],
         sp => [qw{ spanish espanol espanhol }],
         lt => [qw{ lithuanian lituano }],
         ru => [qw{ russo russian rus }],
         it => [qw{ italian italiano ita  }],
         fi => [qw{ finlandes finnish fin }],
         lv => [qw{ latvian letao }],
         no => [qw{ norwegian noruegues nor }],
         hu => [qw{ hungarian hungaro hun }],
         da => [qw{ danish dinamarques }],
         sk => [qw{ slovak eslovaco slk}],
         cs => [qw{ czech checo cze }],
         de => [qw{ german ger deu alemão }],
         nl => [qw{ dutch neerlandês dut }],
         pl => [qw{ polaco polish }],
         el => [qw{ helenico greek grego gre }],
         mt => [qw{ maltese maltes mlt}],
         sl => [qw{ slovenian esloveno slv}],
         et => [qw{ estonian estoniano estonio }],
         tp => [qw{ tetun tétum tetum tet tt}],
         ar => [qw{ arabe arabic ara }],
         tr => [qw{ turky turco turkish tur }],
         uk => [qw{ ukrainian ukrain ukr }],
         is => [qw{ islandes icelandic ice }],
         ro => [qw{ romanian romeno ron }],
         bg => [qw{ bulgaro bulgarian bul }],
         sv => [qw{ sueco swedish swe}],
	     
    );
  for(keys %tags){
     push(@{$tags{$_}},$_);
##     $invtags{$_}= $tags{$_}[0];
     for my $p(@{$tags{$_}}){$invtags{$p}=$tags{$_}[0] }
  }
}

# MODULE PRIVATE FUNCTIONS

sub norm {            # normalizes an array of strings
  my ($string,@norms);
  while ($string = shift @_)
  {
    $string =~ tr/A-Z/a-z/;
    $string =~ s/$norm_tags//gie;
    $string =~ s/[_~-]//g;
    $string =~ s/^(.+)\.[a-z]*?$/$1/;
    push (@norms,$string);
  }
  return @norms;
}

# FROM URLS TO PAIRS

# urls2domain_offsets('file')
sub urls2domain_offsets {
  open (F,$_[0]) || die "could not open $_[0] ($!)";
  my $tell = tell(F);
  my (%results,@results);
  while (<F>)
  {
    m!http://(.*?)/!;
    $results{$1} .= ",".$tell;
    $tell = tell(F)
  }
  close(F);

  map {"$_$results{$_}"} grep {$results{$_} =~ /,.*?,/} keys %results
}

# domain_offsets2blocks("ficheiro_de_urls","a.b.com,12,45","d.e.com,23,56",..)
sub domain_offsets2blocks {
  my $f = shift;
  open (U,$f) || die "could not open $f ($!)";

  my ($temp,@temp,@results,%arq);
  my @lang = qw(pt en fr it da no de);
  # my $patlin = join "|", map {Lingua::Identify::give_tags($_)} @lang;
  my $patlin = join "|", map {jjtags($_)} @lang;
  my $good = join "|", give_extensions();

  my ($sep,$sep2) = ("\n#####\n","=====");

  for (@_)
  {
    my @urls;
    my ($domain,@offsets) = split /,/, $_;
    for (@offsets)
    {
      seek (U,$_,0);
      my $t = <U>;
      chomp $t;
      push @urls, $t
    }
    for (@urls)
    {
      my $a = $_;
      next unless m/\.$good(?:$|\?)/;
      if (s!(.*?)://(.*?)/!!)
      {
        my ($prot,$dom) = ($1,$2);
        undef $temp;
        undef @temp;
        s!($patlin)!push(@temp,$1);$temp.=$1;"@@"!ge;
        s!/(?:\@\@)+/!/!g;
        s!/(?:\@\@)+!/!g;
        s!(?:\@\@)+/!/!g;
#        $temp = join ",", uniques(map {Lingua::Identify::give_names($_)} (grep {/[a-z]/} @temp));
        $temp = join ",", uniques(map {jjnames($_)} (grep {/[a-z]/} @temp));
        $temp ||= "??";
        $arq{"$prot://$dom/$_"} .= "$sep$temp => $a";
      }
    }
    for (keys %arq)
    {
      my @l = split $sep, $arq{$_};
      push @results, \@l if @l > 2
    }
    %arq = ();
  }
  close (U);
  return @results
}

# blocks2pairs($l1,$l2,file_with_bloks)
sub blocks2pairs{
  my $l1 = shift;
  my $l2 = shift;
  my $file = shift;
  my @results;

  open(F,$file) or die("cant open $file\n");
  local $/ = "\%\n";
  while(<F>){
    chomp;
    my @e1=();
    my @e2=();
    for (split(/\s*\n\s*/,$_)){
      ## print "...$_\n";
      my ($l,$u) = /(.*?)\s*=>\s*(.*)/;
      $l =~ /$l1/ && push @e1,$u;
      $l =~ /$l2/ && push @e2,$u;
    }
    for my $e1 (@e1) {
      for my $e2 (@e2) {
         push (@results, [$e1,$e2]) unless($e1 eq $e2)}}
  } 
  close(F);
  return @results;
}

sub blocks2trios {
  my $l1 = 'portuguese';
  my $l2 = 'english';
  my $l3 = 'italian';
  my @results;

  for (@_)
  {
    my (@e1,@e2,@e3);
    for (@{$_})
    {
      my ($l,$u) = /(.*?) => (.*)/;
      $l =~ /$l1/ && push @e1,$u;
      $l =~ /$l2/ && push @e2,$u;
      $l =~ /$l3/ && push @e3,$u;
    }
    for my $e1 (@e1) {for my $e2 (@e2) {for my $e3 (@e3) {push @results, [$e1,$e2,$e3]}}}
  }
  return grep {all_dif(@{$_})} @results;
}

sub all_dif {
  my %b;
  for (@_) { $b{$_}++ }
  for (keys %b) { return 0 if $b{$_} > 1 }
  return 1
}

# pairs2translations(...)
sub pairs2translations {

}

# COMPARISON OF FILES

sub getFilePairs {    # gets translation pairs from list of files (see POD)
  my %opt=(inputis => "files", reqsim => 75);
  my ($conf,@files) = @_;
  %opt = (%opt, %$conf);
  my (@results,%typeof,%langof,@files1,@files2,$path1,$path2);
  die("Error languages are equal\n") if $opt{'l1'} eq $opt{'l2'};
  my $reqsim = $opt{'reqsim'};

  if($opt{'inputis'} eq 'lists')
  {
    @files = ( map { split(/\n/,$_) } readFiles(@files) );
    $opt{'inputis'} = 'files';
  }
  if($opt{'inputis'} eq 'dirs')
  {
    @files = ( map { split(/\n/,`find $_`) } @files );
    $opt{'inputis'} = 'files';
  }
  if($opt{'inputis'} eq 'files')
  {
    foreach (@files)
    {
      (defined ($langof{$_})) && next;
      $typeof{$_} = typeof($_);
      $typeof{$_} || next;
      $langof{$_} = Lingua::Identify::langof(textualize($_));
# print STDERR "'$_-$langof{$_}'\n";
      push(@files1,$_) if ($langof{$_} eq $opt{'l1'});
      push(@files2,$_) if ($langof{$_} eq $opt{'l2'});
    }
    my $n1 = @files1;
    my $n2o = @files2;
# print STDERR "Fim de id. Lingua ($n1/$n2o)\n";
    for $path1 (@files1)
    {
      $n1--;
      my $n2 = $n2o;
      for $path2 (@files2)
      {
        $n2--;
        my $temp;
# print STDERR "Comparing ($n1,$n2)\n\t$path1\n\t$path2\n" ;
        $temp = Guesser::compareFiles($path1,$path2); 
# print STDERR "Debug	$path1	$path2	$temp\n";
        push(@results,[$path1,$path2]) if ($temp > $reqsim);
#        push(@results,[$path1,$path2]) if (Guesser::compareFiles($path1,$path2) > $reqsim);
# print STDERR "Done! ($temp)\n";
      }
# print STDERR ".";
    }
  }
  return @results;
}

sub compareFiles {    # compares two files (returns a percentage)
  my $type = typeof(@_) || return 0;
  my @contents = readFiles(@_);
  my $res_names = straprox(norm(@_));
  @contents || return undef;
  ($val_sizes,$val_names,$val_punct,@val_conts) = @{$weights{$type}};
  ($min_sizes,$min_names,$min_punct,@min_conts) = @{$min_values{$type}};
  my ($valor,$conjunto,@res,@res_cont);
  my $pos = 0;      # heuristic of contents
  foreach (@val_conts)
  {
    $_ || push(@res,0) && next;
    my $res_cont = compareConts($type,$pos,@contents);
    if ($res_cont)
    {
      $valor += $res_cont * $_;
      $conjunto += $_;
      push (@res_cont,$res_cont);
    }
    else {push (@res_cont,undef)}
    $res_cont >= $min_conts[$pos] || return undef;
    $pos++;
  }
  @contents = textualize((type => $type),@contents); # 'garbage' removal

  my ($res_sizes,$min) = compareSizes(@contents); # file size heuristic
  if ($val_sizes)
  {
    $res_sizes > $min_sizes || return undef;
    $valor += $res_sizes * $val_names;
    $conjunto += $val_names;
    push (@res,($min,$res_sizes))
  }
  else {push (@res,($min,0))}

  if ($val_names)    # file name heuristic
  {
    $res_names > $min_names || return undef;
    $valor += $res_names * $val_names;
    $conjunto += $val_names;
    push (@res,$res_names);
  }
  else {push (@res,0)}

  if ($val_punct)    # punctuation heuristic
  {
    my $res_punct = comparePunct(@contents);
    $res_punct > $min_punct || return undef;
    $valor += $res_punct * $val_punct;
    $conjunto += $val_names;
    push (@res,$res_punct);
  }
  else {push (@res,0)}

  my $res = $valor / $conjunto;  # final result calculation

  return wantarray ? ($res,@res,@res_cont) : $res;
}

# OTHER COMPARISONS

sub compareSizes {    # size comparison heuristic
  my $temp = my $min = my $max = length (shift @_);
  foreach (@_)
  {
    $temp = length $_;
    $temp < $min && ($min = $temp);
    $temp > $max && ($max = $temp);
  }
  my $dif = $max - $min;
  return (((1 - (div($dif,$max))) * 100),$min);
}

sub comparePunct {    # punctuation heuristic
  my @puncts = @_;
  foreach (@puncts) {tr/.!?/.!?/cd}
  return (straprox(@puncts));
}

sub straprox {        # string comparison heuristic
  my @strings = @_;
  my ($string1,$string2);
# print STDERR join("	",@strings);
  my $operations = my $lengths = 0;
  while ($string1 = shift @strings)
  {
    $string1 || next;
    for $string2 (@strings)
    {
      $string2 || next;
#      $operations += (abs adist($string1,$string2)) +
#          (abs adist($string2,$string1));
 #     $operations += (abs distance($string1,$string2)) +
 #         (abs distance($string2,$string1));
 #     $lengths += length($string1) + length($string2);
    }
  }
  my $result = ((1 - div($operations,$lengths)) * 100);
# print STDERR "	$result\n";
  return $result;
}

sub compareConts {    # heuristic of contents
  my ($type,$pos,@contents) = @_;

  @conts{$type} || return 0;

  my $cont = ${@conts{$type}}[$pos];

  $cont || return 0;

  my ($all_rights,$all);
  my (%results,%results_new);

  my $c = 0;
  foreach (@contents)
  {
    $c++;
    $_ =~ s/$cont/$results{$1}[$c]++;$&/ge;
  }

  foreach (keys %results)
  {
    my $i = 0;
    while ($i++ < $c)
    {
      my ($temp) = norm($_);
      $results_new{$temp}[$i] += $results{$_}[$i];
    }
  }

  foreach (keys %results_new)
  {
    my $i = 1;
    my $min = my $total = $results_new{$_}[1];
    while ($i++ < $c)
    {
      my $temp = $results_new{$_}[$i];
      $temp < $min && ($min = $temp);
      $total += $temp;
    }
    my $rights = $min * $c;
    my $wrongs = $total - $rights;

    $all_rights += $rights;
    $all += $rights + $wrongs;
  }

  return (($all ? div($all_rights,$all) : 0) * 100);
}

################

sub blocks2pairs_old {
  my ($lang1,$lang2) = ($_[0],$_[1]);
  open(File,$_[2]) || die ("could not open file '$_[2]' ($!).\n");
  my $output = "$_[2].pairs";
  open(FileOut,">$output") || die ("could not create file '$output' ($!).\n");
  my $barra = $/;
  $/ = "\n%\n";
  my ($temp,$l1r,$l2r);
  while (<File>)
  {
    my @block=();
    my $c=0;
    while( m/(.*?)\s*=> (.*)/g){
     my ($l,$u)=($1,$2);
     push(@block,{l=> [split(",",$l)], u=>$u});
     $c++;
    }
    while(@{$block[0]{l}}){
      last unless $block[0]{l}[0] eq $block[1]{l}[0];
      for(@block){shift(@{$_->{l}})}
    }

    undef $l1r;
    undef $l2r;
     
    for(@block){ if($lang1 eq $_->{l}[0]){$l1r = $_->{u} ; last}}
    for(@block){ if($lang2 eq $_->{l}[0]){$l2r = $_->{u} ; last}}

    next unless defined $l1r;
    next unless defined $l2r;
    print FileOut "$l1r	$l2r\n";
  }
  $/ = $barra;
  close (File);
  close (FileOut);
}

sub cleanblocks {
  open(File,$_[0]) || die ("could not open file '$_[0]' ($!).\n");
  open(FileOut,">$_[0].cleaned") || die ("could not create file '$_[0].cleaned' ($!).\n");
  my $barra = $/;
  $/ = "\n%\n";
  while (<File>)
  {
    print FileOut "$_\n%\n";
  }
  $/ = $barra;
}

sub list2blocks {
  my %opt =(lang => [qw(pt en fr)]);
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;

  open(File,$_[0]) || die ("could not open file '$_[0]' ($!).\n");
  my $output = "$_[0].blocks";

  my $langs = join(".",@{$opt{lang}});
  $output =~ s/\.paths\.blocks$/.$langs.blocks/;
  open(FileOut,">$output") || die ("could not create file '$output' ($!).\n");
  my $patlin = join "|", 
          sort {length($b) <=> length($a)} map {Guesser::jjtags($_)} 
                                               @{$opt{lang}};
  print STDERR "PAT=$patlin\n";
  my $sep = "\n#####\n";
  my $sep2 = "=====";
  my ($a,$prot,$dom,$temp,%arq,@temp,@l);
  while (<File>)
  {
    chomp;  
    $a = $_;
    if (s!(?:(.*?)://)?(.*?)/!!)
    {
      ($prot,$dom) = ($1,$2);
      undef @temp;
      undef $temp;
      s![_-]?($patlin)[_-]?!push(@temp,$1);$temp.=$1;"@@"!ige;
      s!/(?:\@\@)+/!/!g;
      s!/(?:\@\@)+!/!g;
      s!(?:\@\@)+/!/!g;
      $temp = join(",",(map {jjnames(lc($_))} @temp));
      $temp = "??" unless $temp;

      $arq{"$prot://$dom/$_"} .= "$sep$temp => $a";
    }
  }
  for (keys %arq)
  {
    @l = split($sep,$arq{$_});
#print "key - $_\narroba l - <<<@l>>>\n";
    if (@l > 2) {print FileOut join("\n",@l),"\n%"}
  }
  close (File);
  close (FileOut);
}

################

sub div {              # common division returning 0 if second argument is 0
  $_[1] ? $_[0] / $_[1] : 0
}

sub uniques {          # returns the input list without repeated elements
  my %v = ();
  return grep { ! $v{$_} ++ } @_
}

1;

__END__

=head1 NAME

Guesser - Perl extension for extracting parallel texts (translations)

=head1 SYNOPSIS

 use Guesser;

 $similarity = compareFiles($filepath1, $filepath2);
 ($similarity, $minsize, ..... ) = compareFiles($filepath1, $filepath2);

 @pairs = getFilePairs($lang1,$lang2,@filepaths);
 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        inputis => "dir", "url" or "file"
                        recsim => "60"}, ,@filepaths);
 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        recsim => "60"}, ,@filepaths)

=head1 DESCRIPTION

Guesser is intended for comparison of files for similarity; this includes file name, size, punctuation and content comparison.

The module provides, among others yet not documented, two main functions for file comparison and search of file pairs.

=head2 C<compareFiles> 

Compares two files and returns a tuple with:

 $similarity, (between 0 .. 100)
 $minsize,
 ....

=head2 C<getFilePairs> 

Searches within a list of files and returns a list of file pairs which similarity is above a required minimum.

 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        recsim => "60"} ,@filepaths)

 ( [path1, path2],[path .... ], ...)

=head1 KNOWN FILE TYPES

These are the known file types for Guesser.pm (with their respective file types):

Active Server Page         - asp
HyperText Markup Language  - html, htm, shtm, shtml
Portable Document Format   - pdf
Postscript                 - ps
Text file                  - txt
eXtensible Markup Language - xml

=head1 AUTHORS

Jose' Alves de Castro, jac@natura.di.uminho.pt

J.Joao Almeida, jj@di.uminho.pt

=head1 SEE ALSO

compare(1), perl(1), Lingua::Identify(3).

=cut
package Guesser;
require Exporter;

our @ISA = qw(Exporter);

our $VERSION = 1;
our %EXPORT_TAGS = ('all' => [ qw() ] );
our @EXPORT_OK = (@{$EXPORT_TAGS{'all'}});
our @EXPORT = qw(
  &urls2domain_offsets
  &domain_offsets2blocks
  &blocks2pairs
  &blocks2trios
);

my %tags;
my %invtags;

sub jjtags{ if(@_){@_ , @{ $tags{$_[0]}} ; } else { keys (%tags)} }
sub jjnames{ @_ ? (map {$invtags{$_}} @_) :    
                  (map {$invtags{$_}} keys (%tags))  
}

use Lingua::Identify;
#use String::Approx 'adist';
#use Text::Levenshtein qw(distance);

use File::Munger;

use strict;

my ($val_sizes,$val_names,$val_punct,$min_sizes,$min_names,$min_punct);
my ($norm_tags,@val_conts,@min_conts);
my (%conts,%weights,%min_values);

BEGIN {

# tudo o que pode ser usado para comparações
  %conts = (
    HTML => [
      '<[aA]\s*[hH][rR][eE][fF]\s*=\s*"(.*?)"\s*>',
      '<[iI][mM][gG]\s*[sS][rR][cC]\s*=\s*"(.*?)".*?>'],
    Text => [' ([A-Z][a-z]*)','\d+'],
    XML => [' ([A-Z][a-z]*)','\d+','<([^/].*?)>'],

    CGI => [
      '<[aA]\s*[hH][rR][eE][fF]\s*=\s*"(.*?)"\s*>',
      '<[iI][mM][gG]\s*[sS][rR][cC]\s*=\s*"(.*?)".*?>'],
    );

# tags de normalização
  #$norm_tags = Lingua::Identify::give_tags();
  $norm_tags = jjtags();

# pesos das várias heurísticas
  %weights = (    # size, names, punctuation, contents*
    HTML => [10,10,0,10,10],
    Text => [10,10,0,5,10],
    XML => [10,10,0,5,10,10],
    PDF => [1,1,0], ASP => [1,1,0], PS => [1,1,0],

    CGI => [10,10,0,10,10],
    );

# valores percentuais mínimos necessários em cada heurística
  %min_values = ( # size, names, punctuation, contents*
    HTML => [50,0,0,0,0],
    Text => [50,0,10,5,50],
    XML => [50,0,10,5,50,20],
    PDF => [0,0,0], 
    ASP => [0,0,0], 
    PS => [0,0,0],

    CGI => [50,0,0,0,0],
    );
  %tags=(
    pt => [qw{ portuguese portugues português port por }],
    en => [qw{ english ingles inglês eng uk }],
    fr => [qw{ french francais français frances francês }],
    es => [qw{ spanish espanol espanhol sp spa}],
    sp => [qw{ spanish espanol espanhol }],
    ru => [qw{ russo russian rus }],
    it => [qw{ italian italiano }],
    no => [qw{ norwegian noruegues nor }],
    de => [qw{ german ger deu alemão}],
    );
  for(keys %tags){
     $invtags{$_}= $tags{$_}[0];
     for my $p(@{$tags{$_}}){$invtags{$p}=$tags{$_}[0] }
  }
}

# MODULE PRIVATE FUNCTIONS

sub norm {            # normalizes an array of strings
  my ($string,@norms);
  while ($string = shift @_)
  {
    $string =~ tr/A-Z/a-z/;
    $string =~ s/$norm_tags//gie;
    $string =~ s/[_~-]//g;
    $string =~ s/^(.+)\.[a-z]*?$/$1/;
    push (@norms,$string);
  }
  return @norms;
}

# FROM URLS TO PAIRS

# urls2domain_offsets('file')
sub urls2domain_offsets {
  open (F,$_[0]) || die "could not open $_[0] ($!)";
  my $tell = tell(F);
  my (%results,@results);
  while (<F>)
  {
    m!http://(.*?)/!;
    $results{$1} .= ",".$tell;
    $tell = tell(F)
  }
  close(F);

  map {"$_$results{$_}"} grep {$results{$_} =~ /,.*?,/} keys %results
}

# domain_offsets2blocks("ficheiro_de_urls","a.b.com,12,45","d.e.com,23,56",..)
sub domain_offsets2blocks {
  my $f = shift;
  open (U,$f) || die "could not open $f ($!)";

  my ($temp,@temp,@results,%arq);
  my @lang = qw(pt en fr it da no de);
  # my $patlin = join "|", map {Lingua::Identify::give_tags($_)} @lang;
  my $patlin = join "|", map {jjtags($_)} @lang;
  my $good = join "|", give_extensions();

  my ($sep,$sep2) = ("\n#####\n","=====");

  for (@_)
  {
    my @urls;
    my ($domain,@offsets) = split /,/, $_;
    for (@offsets)
    {
      seek (U,$_,0);
      my $t = <U>;
      chomp $t;
      push @urls, $t
    }
    for (@urls)
    {
      my $a = $_;
      next unless m/\.$good(?:$|\?)/;
      if (s!(.*?)://(.*?)/!!)
      {
        my ($prot,$dom) = ($1,$2);
        undef $temp;
        undef @temp;
        s!($patlin)!push(@temp,$1);$temp.=$1;"@@"!ge;
        s!/(?:\@\@)+/!/!g;
        s!/(?:\@\@)+!/!g;
        s!(?:\@\@)+/!/!g;
#        $temp = join ",", uniques(map {Lingua::Identify::give_names($_)} (grep {/[a-z]/} @temp));
        $temp = join ",", uniques(map {jjnames($_)} (grep {/[a-z]/} @temp));
        $temp ||= "??";
        $arq{"$prot://$dom/$_"} .= "$sep$temp => $a";
      }
    }
    for (keys %arq)
    {
      my @l = split $sep, $arq{$_};
      push @results, \@l if @l > 2
    }
    %arq = ();
  }
  close (U);
  return @results
}

# blocks2pairs($l1,$l2,file_with_bloks)
sub blocks2pairs{
  my $l1 = shift;
  my $l2 = shift;
  my $file = shift;
  my @results;

  open(F,$file) or die("cant open $file\n");
  local $/ = "\%\n";
  while(<F>){
    chomp;
    my @e1=();
    my @e2=();
    for (split(/\s*\n\s*/,$_)){
      ## print "...$_\n";
      my ($l,$u) = /(.*?)\s*=>\s*(.*)/;
      $l =~ /$l1/ && push @e1,$u;
      $l =~ /$l2/ && push @e2,$u;
    }
    for my $e1 (@e1) {
      for my $e2 (@e2) {
         push (@results, [$e1,$e2]) unless($e1 eq $e2)}}
  } 
  close(F);
  return @results;
}

sub blocks2trios {
  my $l1 = 'portuguese';
  my $l2 = 'english';
  my $l3 = 'italian';
  my @results;

  for (@_)
  {
    my (@e1,@e2,@e3);
    for (@{$_})
    {
      my ($l,$u) = /(.*?) => (.*)/;
      $l =~ /$l1/ && push @e1,$u;
      $l =~ /$l2/ && push @e2,$u;
      $l =~ /$l3/ && push @e3,$u;
    }
    for my $e1 (@e1) {for my $e2 (@e2) {for my $e3 (@e3) {push @results, [$e1,$e2,$e3]}}}
  }
  return grep {all_dif(@{$_})} @results;
}

sub all_dif {
  my %b;
  for (@_) { $b{$_}++ }
  for (keys %b) { return 0 if $b{$_} > 1 }
  return 1
}

# pairs2translations(...)
sub pairs2translations {

}

# COMPARISON OF FILES

sub getFilePairs {    # gets translation pairs from list of files (see POD)
  my %opt=(inputis => "files", reqsim => 75);
  my ($conf,@files) = @_;
  %opt = (%opt, %$conf);
  my (@results,%typeof,%langof,@files1,@files2,$path1,$path2);
  die("Error languages are equal\n") if $opt{'l1'} eq $opt{'l2'};
  my $reqsim = $opt{'reqsim'};

  if($opt{'inputis'} eq 'lists')
  {
    @files = ( map { split(/\n/,$_) } readFiles(@files) );
    $opt{'inputis'} = 'files';
  }
  if($opt{'inputis'} eq 'dirs')
  {
    @files = ( map { split(/\n/,`find $_`) } @files );
    $opt{'inputis'} = 'files';
  }
  if($opt{'inputis'} eq 'files')
  {
    foreach (@files)
    {
      (defined ($langof{$_})) && next;
      $typeof{$_} = typeof($_);
      $typeof{$_} || next;
      $langof{$_} = Lingua::Identify::langof(textualize($_));
# print STDERR "'$_-$langof{$_}'\n";
      push(@files1,$_) if ($langof{$_} eq $opt{'l1'});
      push(@files2,$_) if ($langof{$_} eq $opt{'l2'});
    }
    my $n1 = @files1;
    my $n2o = @files2;
# print STDERR "Fim de id. Lingua ($n1/$n2o)\n";
    for $path1 (@files1)
    {
      $n1--;
      my $n2 = $n2o;
      for $path2 (@files2)
      {
        $n2--;
        my $temp;
# print STDERR "Comparing ($n1,$n2)\n\t$path1\n\t$path2\n" ;
        $temp = Guesser::compareFiles($path1,$path2); 
# print STDERR "Debug	$path1	$path2	$temp\n";
        push(@results,[$path1,$path2]) if ($temp > $reqsim);
#        push(@results,[$path1,$path2]) if (Guesser::compareFiles($path1,$path2) > $reqsim);
# print STDERR "Done! ($temp)\n";
      }
# print STDERR ".";
    }
  }
  return @results;
}

sub compareFiles {    # compares two files (returns a percentage)
  my $type = typeof(@_) || return 0;
  my @contents = readFiles(@_);
  my $res_names = straprox(norm(@_));
  @contents || return undef;
  ($val_sizes,$val_names,$val_punct,@val_conts) = @{$weights{$type}};
  ($min_sizes,$min_names,$min_punct,@min_conts) = @{$min_values{$type}};
  my ($valor,$conjunto,@res,@res_cont);
  my $pos = 0;      # heuristic of contents
  foreach (@val_conts)
  {
    $_ || push(@res,0) && next;
    my $res_cont = compareConts($type,$pos,@contents);
    if ($res_cont)
    {
      $valor += $res_cont * $_;
      $conjunto += $_;
      push (@res_cont,$res_cont);
    }
    else {push (@res_cont,undef)}
    $res_cont >= $min_conts[$pos] || return undef;
    $pos++;
  }
  @contents = textualize((type => $type),@contents); # 'garbage' removal

  my ($res_sizes,$min) = compareSizes(@contents); # file size heuristic
  if ($val_sizes)
  {
    $res_sizes > $min_sizes || return undef;
    $valor += $res_sizes * $val_names;
    $conjunto += $val_names;
    push (@res,($min,$res_sizes))
  }
  else {push (@res,($min,0))}

  if ($val_names)    # file name heuristic
  {
    $res_names > $min_names || return undef;
    $valor += $res_names * $val_names;
    $conjunto += $val_names;
    push (@res,$res_names);
  }
  else {push (@res,0)}

  if ($val_punct)    # punctuation heuristic
  {
    my $res_punct = comparePunct(@contents);
    $res_punct > $min_punct || return undef;
    $valor += $res_punct * $val_punct;
    $conjunto += $val_names;
    push (@res,$res_punct);
  }
  else {push (@res,0)}

  my $res = $valor / $conjunto;  # final result calculation

  return wantarray ? ($res,@res,@res_cont) : $res;
}

# OTHER COMPARISONS

sub compareSizes {    # size comparison heuristic
  my $temp = my $min = my $max = length (shift @_);
  foreach (@_)
  {
    $temp = length $_;
    $temp < $min && ($min = $temp);
    $temp > $max && ($max = $temp);
  }
  my $dif = $max - $min;
  return (((1 - (div($dif,$max))) * 100),$min);
}

sub comparePunct {    # punctuation heuristic
  my @puncts = @_;
  foreach (@puncts) {tr/.!?/.!?/cd}
  return (straprox(@puncts));
}

sub straprox {        # string comparison heuristic
  my @strings = @_;
  my ($string1,$string2);
# print STDERR join("	",@strings);
  my $operations = my $lengths = 0;
  while ($string1 = shift @strings)
  {
    $string1 || next;
    for $string2 (@strings)
    {
      $string2 || next;
#      $operations += (abs adist($string1,$string2)) +
#          (abs adist($string2,$string1));
 #     $operations += (abs distance($string1,$string2)) +
 #         (abs distance($string2,$string1));
 #     $lengths += length($string1) + length($string2);
    }
  }
  my $result = ((1 - div($operations,$lengths)) * 100);
# print STDERR "	$result\n";
  return $result;
}

sub compareConts {    # heuristic of contents
  my ($type,$pos,@contents) = @_;

  @conts{$type} || return 0;

  my $cont = ${@conts{$type}}[$pos];

  $cont || return 0;

  my ($all_rights,$all);
  my (%results,%results_new);

  my $c = 0;
  foreach (@contents)
  {
    $c++;
    $_ =~ s/$cont/$results{$1}[$c]++;$&/ge;
  }

  foreach (keys %results)
  {
    my $i = 0;
    while ($i++ < $c)
    {
      my ($temp) = norm($_);
      $results_new{$temp}[$i] += $results{$_}[$i];
    }
  }

  foreach (keys %results_new)
  {
    my $i = 1;
    my $min = my $total = $results_new{$_}[1];
    while ($i++ < $c)
    {
      my $temp = $results_new{$_}[$i];
      $temp < $min && ($min = $temp);
      $total += $temp;
    }
    my $rights = $min * $c;
    my $wrongs = $total - $rights;

    $all_rights += $rights;
    $all += $rights + $wrongs;
  }

  return (($all ? div($all_rights,$all) : 0) * 100);
}

################

sub blocks2pairs_old {
  my ($lang1,$lang2) = ($_[0],$_[1]);
  open(File,$_[2]) || die ("could not open file '$_[2]' ($!).\n");
  my $output = "$_[2].pairs";
  open(FileOut,">$output") || die ("could not create file '$output' ($!).\n");
  my $barra = $/;
  $/ = "\n%\n";
  my ($temp,$l1r,$l2r);
  while (<File>)
  {
    my @block=();
    my $c=0;
    while( m/(.*?)\s*=> (.*)/g){
     my ($l,$u)=($1,$2);
     push(@block,{l=> [split(",",$l)], u=>$u});
     $c++;
    }
    while(@{$block[0]{l}}){
      last unless $block[0]{l}[0] eq $block[1]{l}[0];
      for(@block){shift(@{$_->{l}})}
    }

    undef $l1r;
    undef $l2r;
     
    for(@block){ if($lang1 eq $_->{l}[0]){$l1r = $_->{u} ; last}}
    for(@block){ if($lang2 eq $_->{l}[0]){$l2r = $_->{u} ; last}}

    next unless defined $l1r;
    next unless defined $l2r;
    print FileOut "$l1r	$l2r\n";
  }
  $/ = $barra;
  close (File);
  close (FileOut);
}

sub cleanblocks {
  open(File,$_[0]) || die ("could not open file '$_[0]' ($!).\n");
  open(FileOut,">$_[0].cleaned") || die ("could not create file '$_[0].cleaned' ($!).\n");
  my $barra = $/;
  $/ = "\n%\n";
  while (<File>)
  {
    print FileOut "$_\n%\n";
  }
  $/ = $barra;
}

sub list2blocks {
  my %opt =(lang => [qw(pt en fr)]);
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;

  open(File,$_[0]) || die ("could not open file '$_[0]' ($!).\n");
  my $output = "$_[0].blocks";
  my $langs = join(".",@{$opt{lang}});
  $output =~ s/\.paths\.blocks$/.$langs.blocks/;
  open(FileOut,">$output") || die ("could not create file '$output' ($!).\n");
  my $patlin = join "|", 
          sort {length($b) <=> length($a)} map {Guesser::jjtags($_)} 
                                               @{$opt{lang}};
  print STDERR "PAT=$patlin\n";
  my $sep = "\n#####\n";
  my $sep2 = "=====";
  my ($a,$prot,$dom,$temp,%arq,@temp,@l);
  while (<File>)
  {
    chomp;  
    $a = $_;
    if (s!(?:(.*?)://)?(.*?)/!!)
    {
      ($prot,$dom) = ($1,$2);
      undef @temp;
      undef $temp;
      s![_-]?($patlin)[_-]?!push(@temp,$1);$temp.=$1;"@@"!ge;
      s!/(?:\@\@)+/!/!g;
      s!/(?:\@\@)+!/!g;
      s!(?:\@\@)+/!/!g;
      $temp = join(",",(map {jjnames($_)} @temp));
      $temp = "??" unless $temp;

      $arq{"$prot://$dom/$_"} .= "$sep$temp => $a";
    }
  }
  for (keys %arq)
  {
    @l = split($sep,$arq{$_});
#print "key - $_\narroba l - <<<@l>>>\n";
    if (@l > 2) {print FileOut join("\n",@l),"\n%"}
  }
  close (File);
  close (FileOut);
}

################

sub div {              # common division returning 0 if second argument is 0
  $_[1] ? $_[0] / $_[1] : 0
}

sub uniques {          # returns the input list without repeated elements
  my %v = ();
  return grep { ! $v{$_} ++ } @_
}

1;

__END__

=head1 NAME

Guesser - Perl extension for extracting parallel texts (translations)

=head1 SYNOPSIS

 use Guesser;

 $similarity = compareFiles($filepath1, $filepath2);
 ($similarity, $minsize, ..... ) = compareFiles($filepath1, $filepath2);

 @pairs = getFilePairs($lang1,$lang2,@filepaths);
 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        inputis => "dir", "url" or "file"
                        recsim => "60"}, ,@filepaths);
 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        recsim => "60"}, ,@filepaths)

=head1 DESCRIPTION

Guesser is intended for comparison of files for similarity; this includes file name, size, punctuation and content comparison.

The module provides, among others yet not documented, two main functions for file comparison and search of file pairs.

=head2 C<compareFiles> 

Compares two files and returns a tuple with:

 $similarity, (between 0 .. 100)
 $minsize,
 ....

=head2 C<getFilePairs> 

Searches within a list of files and returns a list of file pairs which similarity is above a required minimum.

 @pairs = getFilePairs({l1     => "pt",
                        l2     => "en",
                        recsim => "60"} ,@filepaths)

 ( [path1, path2],[path .... ], ...)

=head1 KNOWN FILE TYPES

These are the known file types for Guesser.pm (with their respective file types):

Active Server Page         - asp
HyperText Markup Language  - html, htm, shtm, shtml
Portable Document Format   - pdf
Postscript                 - ps
Text file                  - txt
eXtensible Markup Language - xml

=head1 AUTHORS

Jose' Alves de Castro, jac@natura.di.uminho.pt

J.Joao Almeida, jj@di.uminho.pt

=head1 SEE ALSO

compare(1), perl(1), Lingua::Identify(3).

=cut
