#!/usr/bin/perl -w -s

## use Lingua::PT::PLN;
use utf8::all;
use feature 'signatures'; 
no warnings qw(experimental::signatures);

our ($f,$sub,$verbose,$istxt1,$istxt2,$ignorecase,$pcase,$pacc,$minoco,$log,$minratio);

$ignorecase = 1 if $ignorecase;
$ignorecase = 0 if $pcase;
$minratio //=0;
my $file1 = shift;
my $file2 = shift; # if undefined 
if(not defined $file2){  ## just calculates file1 oco
   my ($dic1,$total1)= freq_from_txt({ignorecase => $ignorecase || 0}, $file1);
   if($pcase){   ## smart recapitalization
       birecapitaliza_pref($dic1,$dic1);
   }
   if($pacc){   ## smart recapitalization
       bireaccent_pref($dic1,$dic1);
   }
   for my $w ( sort {$dic1->{$b} <=> $dic1->{$a} or $a cmp $b} keys(%$dic1)){
	   print "$dic1->{$w}\t$w\n";
   }
   exit 0; }
else{$file2  = shift or die ("see perldoc freqnormpt\n"); }

$minoco  ||= 5  ; #minimum number of ocorrences
$minfreq ||= 0  ; #minimum number of ocorrences per million

print STDERR "Comparing frequencies from $file1 and $file2\n" if $verbose;

my ($d1,$total1,$d2,$total2);

if($istxt1){
   ($d1,$total1) = freq_from_txt({ignorecase => $ignorecase || 0}, $file1) }
else       { ($d1,$total1) = load_freq($file1)     }
print STDERR "File $file1: done\n" if $verbose;
 
if($istxt2){
   ($d2,$total2) = freq_from_txt({ignorecase => $ignorecase || 0}, $file2) }
else       { ($d2,$total2) = load_freq($file2)     }
print STDERR "File $file2: done\n" if $verbose;

### compare %$d1 %$d2

if($pcase){   ## smart recapitalization
   birecapitaliza_pref($d1,$d2);
}
if($pacc){   ## smart recapitalization
   bireaccent_pref($d1,$d2);
}

if($sub){ @keys{(keys %$d1, keys %$d2)} = 1;}
else{     @keys{(keys %$d1)}            = 1;}

$v = 1000000;
my $z1= 0.5/$total1;
my $z2= 0.5/$total2;
for (keys %keys) {
  next if max($d1->{$_}||0,$d2->{$_}||0) < $minoco;

  $milhao1 = ($d1->{$_}||0)/$total1;
  $milhao2 = ($d2->{$_}||0)/$total2;
  $delta = $milhao1-$milhao2;
  $delta*=$v;
#  next if abs($delta) < $minoco;

  $p1 = $v*$milhao1|| $z1 ;
  $p2 = $v*$milhao2|| $z2 ;
  next if max($p1,$p2) < $minfreq ;

  if($log){
     $comp = log($p1)-log($p2); #FIXME: log() - log()/???
     if($comp > $minratio || !$sub){
        print sprintf('%6.9f ',$comp), "$_ : v1(",int($p1),") v2(",int($p2),") ",int($delta),"\n";
     }
  }
  else {
     $comp = $p1/($p1+$p2);
     #if ($comp>.6 || $comp<.4)
     if($comp > 0.5 || !$sub){  ##FIXME
        print sprintf('%6.9f ',$comp), "$_ : v1(",int($p1),") v2(",int($p2),") ",int($delta),"\n";
     }
  }
}


# Load a frequence file, returns a reference to an associative array
sub load_freq {
  my %opt =(ignorecase => 0);
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my $file = shift;
  my $data = {};
  my $t=0;
  open F, "$file" or die "Cannot open file: $file ($!)\n";
  while(<F>) {
    chomp;
    m!^\s*(\S+)\s+(\S+)!;
    if($opt{ignorecase} ==1 ){ $data->{lc($2)} += $1; }
    else                     { $data->{$2} = $1;      }
    $t += $1;
  }
  close F;

#  if($opt{ignorecase} == 2){   ## -pcase
#    off_recapitaliza_pref($data);
#  }
  return ($data,$t);
}

sub freq_from_txt{
  my %opt =(ignorecase => 0);
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my %oco;
  my $t=0;
  my @fs = @_;
  for my $f (@fs){
     open(F1,"<",$f);
     while(<F1>){
        for my $w (m/(EMOJI_._|\w(?:[-']\w|\w)+|[👍-🫣🔕😃😀]|:-?\)|:-?\()/g){
#          next if $w =~ /^\d+$/;    ## ignore numbers
           next if $w =~ /^\d+/;     ## ignore words starting by numbers
           if($opt{ignorecase} == 1 ){ $oco{lc($w)}++ }
           else                      { $oco{$w    }++ }
        }
     }
     close F1;
  }

  for (values %oco){ $t += $_ }

#  if ($opt{ignorecase} == 2){
#    off_recapitaliza_pref(\%oco);
#  }

  return (\%oco,$t);
}

sub birecapitaliza_pref($oco1, $oco2, $opt={}){
   my %opt =(
      keep => +{ qw( 

		 a 1 à 1 á 1 
		 aí 1
		 alívio 1
		 ânimo 1
		 após 1 
		 ás 1
		 até 1 
		 avó 1 avô 1
		 da 1 dá 1 
		 daí 1
		 de 1 dê 1
		 denúncia 1
		 dívidas 1 dívida 1
		 do 1 dó 1 
		 e 1 é 1 
         esta 1 está 1
		 há 1 
		 Irão 1
		 influência 1 influências 1
		 lê 1
		 má 1 ma 1
		 mamã 1
		 mas 1 más 1 
		 marquês 1 Marques 1 Marquês 1
		 nós 1 nos 1
		 país 1 pais 1
		 papá 1
		 para 1 pára 1 
		 pêlo 1
		 pôde 1
		 por 1 pôr 1 pôs 1
		 porém 1
		 Tomé 1 Tomás 1
		 porque 1 porquê 1 
		 que 1 quê 1 
		 saía 1 
		 sê 1 sé 1
		 sobre 1 
		 tras 1 
		 têm 1 
		 vária 1 várias 1
		 vêm 1
		 vós 1 vos 1

      ) } 
   );

   %opt = (%opt , %$opt);

   my %tot = ( %$oco1 );
   for my $w (keys %$oco2){ 
      $tot{$w} += $oco2->{$w} 
   }
   
   for my $w (keys %tot){
      next if $opt{keep}{$w};
      next unless $tot{$w};
      if ($w =~ /[A-ZÁÉÍÓÚÂÊÔ]./ ){   ## preferencial capitalization (50%)
         my $w2 = lc($w);
         if ($tot{$w2}){
           if( $tot{$w} > 1 * $tot{$w2} ){ ## w > lc(w) = capitalize
              if( $oco1->{$w2}){ 
                 $oco1->{$w} += $oco1->{$w2};
                 delete $oco1->{$w2};
              }
              if( $oco2->{$w2}){ 
                 $oco2->{$w} += $oco2->{$w2};
                 delete $oco2->{$w2};
              }
           }
           elsif( $tot{$w2} >= 1 * $tot{$w} ){ ## w < lc(w) = uncapitalize
              if( $oco1->{$w}){ 
                 $oco1->{$w2} += $oco1->{$w};
                 delete $oco1->{$w};
              }
              if( $oco2->{$w}){ 
                 $oco2->{$w2} += $oco2->{$w};
                 delete $oco2->{$w};
              }
              $w = $w2
           }
         }
      }

	  #      if ($w =~ /[ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùçãõ]/ ){ ## preferencial accent (60%)
	  #   my $w2 =($w =~ y{ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùãõ}{AEIOUAEOaeiouaeouaeiouao}r);
	  #   next unless ($tot{$w2} and $w2 ne $w);
	  #   if( $tot{$w} >= 2 * $tot{$w2} ){ ## adiciona acento às outras
	  #      if( $oco1->{$w2}){ 
	  #         $oco1->{$w} += $oco1->{$w2};
	  #         delete $oco1->{$w2};
	  #      }
	  #      if( $oco2->{$w2}){ 
	  #         $oco2->{$w} += $oco2->{$w2};
	  #         delete $oco2->{$w2};
	  #      }
	  #   }
	  #}

	  #if ($w =~ /[ç]/ ){                 ## preferencial ç (75%)
	  #   my $w2 = ($w =~ y{ç}{c}r) ;
	  #   next unless $tot{$w2};
	  #   if( $tot{$w} > 3 * $tot{$w2} ){ ## adiciona ç às outras
	  #      if( $oco1->{$w2}){ 
	  #         $oco1->{$w} += $oco1->{$w2};
	  #         delete $oco1->{$w2};
	  #      }
	  #      if( $oco2->{$w2}){ 
	  #         $oco2->{$w} += $oco2->{$w2};
	  #         delete $oco2->{$w2};
	  #      }
	  #   }
	  #}

   }
}


sub bireaccent_pref($oco1, $oco2, $opt={}){
   my %opt =(
      keep => +{ qw( 

		 a 1 à 1 á 1 
		 aí 1
		 alívio 1
		 ânimo 1
		 após 1 
		 ás 1
		 até 1 
		 avó 1 avô 1
		 da 1 dá 1 
		 daí 1
		 de 1 dê 1
		 denúncia 1
		 dívidas 1 dívida 1
		 do 1 dó 1 
		 e 1 é 1 
         esta 1 está 1
		 há 1 
		 Irão 1
		 influência 1 influências 1
		 lê 1
		 má 1 ma 1
		 mamã 1
		 mas 1 más 1 
		 marquês 1 Marques 1 Marquês 1
		 nós 1 nos 1
		 país 1 pais 1
		 papá 1
		 para 1 pára 1 
		 pêlo 1
		 pôde 1
		 por 1 pôr 1 pôs 1
		 porém 1
		 Tomé 1 Tomás 1
		 porque 1 porquê 1 
		 que 1 quê 1 
		 saía 1 
		 sê 1 sé 1
		 sobre 1 
		 tras 1 
		 têm 1 
		 vária 1 várias 1
		 vêm 1
		 vós 1 vos 1
      ) } 
   );

   %opt = (%opt , %$opt);

   my %tot = ( %$oco1 );
   for my $w (keys %$oco2){ 
      $tot{$w} += $oco2->{$w} 
   }
   
   for my $w (keys %tot){
      next if $opt{keep}{$w};
      next unless $tot{$w};
	  #if ($w =~ /[A-ZÁÉÍÓÚÂÊÔ]./ ){   ## preferencial capitalization (50%)
	  #   my $w2 = lc($w);
	  #   if ($tot{$w2}){
	  #     if( $tot{$w} > 1 * $tot{$w2} ){ ## w > lc(w) = capitalize
	  #        if( $oco1->{$w2}){ 
	  #           $oco1->{$w} += $oco1->{$w2};
	  #           delete $oco1->{$w2};
	  #        }
	  #        if( $oco2->{$w2}){ 
	  #           $oco2->{$w} += $oco2->{$w2};
	  #           delete $oco2->{$w2};
	  #        }
	  #     }
	  #     elsif( $tot{$w2} >= 1 * $tot{$w} ){ ## w < lc(w) = uncapitalize
	  #        if( $oco1->{$w}){ 
	  #           $oco1->{$w2} += $oco1->{$w};
	  #           delete $oco1->{$w};
	  #        }
	  #        if( $oco2->{$w}){ 
	  #           $oco2->{$w2} += $oco2->{$w};
	  #           delete $oco2->{$w};
	  #        }
	  #        $w = $w2
	  #     }
	  #   }
	  #}

      if ($w =~ /[ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùçãõ]/ ){ ## preferencial accent (60%)
         my $w2 =($w =~ y{ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùãõ}{AEIOUAEOaeiouaeouaeiouao}r);
         next unless ($tot{$w2} and $w2 ne $w);
         if( $tot{$w} >= 2 * $tot{$w2} ){ ## adiciona acento às outras
            if( $oco1->{$w2}){ 
               $oco1->{$w} += $oco1->{$w2};
               delete $oco1->{$w2};
            }
            if( $oco2->{$w2}){ 
               $oco2->{$w} += $oco2->{$w2};
               delete $oco2->{$w2};
            }
         }
      }

      if ($w =~ /[ç]/ ){                 ## preferencial ç (75%)
         my $w2 = ($w =~ y{ç}{c}r) ;
         next unless $tot{$w2};
         if( $tot{$w} > 3 * $tot{$w2} ){ ## adiciona ç às outras
            if( $oco1->{$w2}){ 
               $oco1->{$w} += $oco1->{$w2};
               delete $oco1->{$w2};
            }
            if( $oco2->{$w2}){ 
               $oco2->{$w} += $oco2->{$w2};
               delete $oco2->{$w2};
            }
         }
      }

   }
}

sub off_recapitaliza_pref($oco, $opt={}){
   my %opt =(
      keep => +{ qw( 
         esta 1 para 1 e 1 a 1 até 1 após 1 por 1 sobre 1 tras 1 mas 1 porque 1 
         que 1 da 1 dá 1 de 1 do 1 à 1 à 1 é 1 há 1 está 1
      ) } 
   );

   %opt = (%opt , %$opt);

   for my $w (keys %$oco){
      next if $opt{keep}{$w};
      next unless $oco->{$w};
      if ($w =~ /[A-ZÁÉÍÓÚÂÊÔ]./ ){
         my $w2 = lc($w);
         next unless $oco->{$w2};
         if( $oco->{$w} > 2 * $oco->{$w2} ){
            $oco->{$w} += $oco->{$w2};
            delete $oco->{$w2};
         }
         elsif( $oco->{$w2} > 2 * $oco->{$w} ){
            $oco->{$w2} += $oco->{$w};
            delete $oco->{$w};
            $w = $w2
         }
      }

      if ($w =~ /[ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùçãõ]/ ){
         my $w2 = ($w =~ y{ÁÉÍÓÚÂÊÔáéíóúâêôûàèìòùãõ}{AEIOUAEOaeiouaeouaeiouao}r) ;
         next unless $oco->{$w2};
         if( $oco->{$w} > 2 * $oco->{$w2} ){   ## adiciona acento às outras
            $oco->{$w} += $oco->{$w2};
            delete $oco->{$w2};
         }
#         elsif( $oco->{$w2} > 2 * $oco->{$w} { ## retira acento às minoritárias
#            $oco->{$w2} += $oco->{$w};
#            delete $oco->{$w};
#            $w = $w2
#         }
      }

   }
   return $oco
}

sub max{ (sort( @_ ))[-1] }
sub min{ (sort( @_ ))[0] }

__END__

=encoding utf8

=head1 NAME

freqcomp - compare word frequences vectors

=head1 SYNOPSIS

 freqcomp corpus1.oco corpus2.oco      | sort -n > output
 freqcomp -sub corpus1.oco corpus2.oco | sort -nr > WhatisNewInCorpus1
 freqcomp -istxt1 -sub corpus1.txt corpus2.oco

=head1 DESCRIPTION

Given the results of C<freqnormpt>(vector of lemmas), or C<freqoco> (vector of words), C<freqcomp>
compares them showing the words with a "difference measure".

The "difference measure" is a number in the interval [0,1]:

  . 1   -- word just in corpus1
  . 0   -- word just in corpus2
  . 0.5 -- similar distribution in both corpus

=head1 Options

-sub     subtract

Just present the word between 0.5 and 1 (What is new in corpus1)

-istxt1   first argument is a text instead of word frequance vector

-istxt2   second argument is a text instead of word frequance vector

-ignorecase

-pcase    preferencial case  and preferencial accent

-pacc     preferencial accent

-verbose

 -minratio   minimum logaritmic difference
            eg(minratio=2.30  (=log(10)) -- 10 times bigger)


C<-minoco=20>   defines the minimum (def=5) number of ocurrences (words are
    ignored if they occur less then minoco times)

C<-minfreq=20>   defines the minimum (def=0) frequence per million (words are
    ignored if they occur less then that)

=head1 AUTHOR

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

Alberto Simoes, albie@alfarrabio.di.uminho.pt

=head1 SEE ALSO

freqnormpt

freqoco

surprise

Lingua::PT::PLN

perl(1).

=cut