#!/usr/bin/perl -w
##-------------------------------------------------------------##
# $Author: oravecz $
# $Date: $
# $Header: $
#
# Desc: script to compile HU associate list on the basis of EN, DE, FR lists and HU text
#
# Bugs:
# probably a lot
# and a lot more
# Todo:
#  -
# Change log:
#
#_______________________________________________________________##
use strict;
if ($ENV{OSTYPE} =~ m/linux/i) {
require 5.004 or die "We need at least 5.004!";
use POSIX qw(locale_h);
} else {
  die "Alas! We need Linux...";
}
setlocale(LC_CTYPE, "hu_HU");
use locale;

use Getopt::Std;
my $debug = 0;
my %Opt;
my $entrans = "/home2/projects/eurovoc/associate_lists/translations/en.out.iso.txt";
my $detrans = "/home2/projects/eurovoc/associate_lists/translations/de.out.iso.txt";
my $frtrans = "/home2/projects/eurovoc/associate_lists/translations/fr.out.iso.txt";

my $threshold = 1;

my $usage = <<EUS ;

Script to make HU associate lists.

Usage: $0 [-h|d|m|a|o] [-t num] [-e|g|f transfile]
 e|g|f file appropriate EN/DE/FR translation lists. Default values:
            EN: $entrans
            DE: $detrans
            FR: $frtrans
 m          Add splitted (+) MWE units separatly for each member
 a          Add and use token info from HU CELEX file
 t num      Min frequency for translation equivalents to include
            Default: $threshold
 o          Interpret 'a' and 't' disjunctively (either in corpus
            OR above threshold). Default is conjunctive
            (trans must be in corpus AND above threshold
            to be included).
            interpretation.
 d          print out debugging info
 h          print out usage info
EUS

getopts('hdmaoe:g:f:t:', \%Opt) or do {print STDERR "$usage"; exit 1};
$debug = 1 if $Opt{'d'} ;
if ($Opt{'h'}) {print STDERR "$usage";exit 1};

# 1. Read in translations lists.
$entrans = $Opt{'e'} if $Opt{'e'};
$detrans = $Opt{'g'} if $Opt{'g'};
$frtrans = $Opt{'f'} if $Opt{'f'};
$threshold = $Opt{'t'} if $Opt{'t'};

my %en_hu;
my %de_hu;
my %fr_hu;

# Special processing is needed for EN file bec. of MWEs
open("EN","<$entrans") or die "Can't open $entrans $!";

print STDERR "Processing $entrans ...\n";

EN:
while (<EN>) {
  # skip entry w.o. trans or spurious entry
  next if /=\s*$/ or /^\s/;
  chomp;
  $_ = clean_up($_);
  # special EN processing here
  if (/=.*\+/ and $Opt{'m'}) {
    my ($en,$hu) = split(/=/,$_);
    # MWE with separate translations, each stored independently
    my @hunw = split(/\+/,$hu);
    foreach my $enw (split(/\s+/,$en)) {
      foreach my $hunw (split(/,/,(shift @hunw))) {
	# store translation unless unknown
	add_entry(\%en_hu,$enw,$hunw,"EN");
	next EN unless @hunw;
      }
    }
  } else {
    next if /=.*\+/;
    # regular processing for all dictionaries
    process_tr(\%en_hu,$_,"EN");
  }
}

print_out(\%en_hu,"EN") if $debug;

# DE processing
read_tr("DE");
# FR processing
read_tr("FR");

# Process descriptors
# files:
my $endesc = "/home2/projects/eurovoc/associate_lists/en_profile.iso";
my $dedesc = "/home2/projects/eurovoc/associate_lists/de_profile.iso";
my $frdesc = "/home2/projects/eurovoc/associate_lists/fr_profile.iso";
my $hudesc = "/home2/projects/eurovoc/associate_lists/hungarian/hu_profile.iso";

# Main descriptor data: LANG hash indexed on descriptors. Content: ref to hash indexed on
# associate token, with weight content: $lang_desc{$descriptor}->{$associate} = $weight

my (%en_desc,%de_desc,%fr_desc,%hu_desc,%desc);

read_desc("EN");
read_desc("DE");
read_desc("FR");
read_desc("HU");

############## Calculation of trans equivalents ###########################

# For each descriptor:
#  - Calculate freqlist of union of all HU translations
#  - Check if token is present in corresponding HU CELEX file(s) if $Opt{'a'}

# hash for descriptor -> file code mapping
my %celex_desc if $Opt{'a'};

if ($Opt{'a'}) {
  my $eq_file =
    "/home2/projects/eurovoc/associate_lists/huAssignmentWithCelex.txt";
  # Note: there is an error in the mapping file: All 15 digit IDs should have a leading '0'!
  open(CID,"<$eq_file") or die "Can't open $eq_file $!";
  while (<CID>) {
    next unless /^[0-9]/;
    my ($celex_code,$void,$desc,$rest) = split(/\t/,$_);
    unless (length($celex_code) == 10) {
      print STDERR "Line $.: Error in file ID: '$celex_code'\n";
      next;
    }
    if (length($desc) != 16) {
       print STDERR "Line $.: Error in DESC: '$desc'\n";
       $desc = '0' . $desc;
    }
    $celex_desc{$desc}{$celex_code}++;
  }
}

# Added extra: description of descriptors:
my $thesa =
  "/home2/projects/item2003/eurovoc/associate_lists/desc_thesaurus_combined.lst";
my %thesa;
open(TH,"<$thesa") or die "Can't open $thesa $!";
print STDERR "Processing thesaurus ...";
while (<TH>) {
  chomp;
  my ($desc,$text) = split(/\t+/,$_);
  if (length($desc) != 16) {
    print STDERR "Line $.: Error in DESC: '$desc'\n";
  }
  push @{$thesa{$desc}}, $text;
}
close(TH);
print STDERR " Done.\n";

my $celex_dir = "/home2/projects/eurovoc/xml/text";
my %list;
my $celex_string;
my $match = 0;

####### Read in hand translated list... ############
my $handlist = "/home2/projects/eurovoc/associate_lists/hungarian/HU_associates.lst";
my %hand_en_hu;
open(HAND,"<$handlist") or die "Can't open $handlist $!";
print STDERR "Processing hand translation file ...";
while (<HAND>) {
  chomp;
  my ($en,$hu) = split(/\t+/,$_);
  $en = clean_token($en);
  $hu = clean_token($hu);
  $hand_en_hu{$en} = $hu;
}
close(HAND);
print STDERR " Done.\n";

# For each descriptor:
#  - prepare a list of HU words from translation hashes
#  - prepare a long string from corresponding HU CELEX file text(s) if $Opt{'a'},
#   and check if translation can be matched in this string
#
# Calculation of weight:
# 0. Trained data: use available weight
# 1. Hand-translated data: use weight of English equivalent.
# 2. Machine translated data: use average of existing EN/DE/FR equivalents.

my $count = 0;
foreach my $desc (keys %desc) {
  $count++;
  print STDERR "$count\r";
  my $hu = 0;
  my $en = 0;
  $hu = 1 if exists($hu_desc{$desc});
  $en = 1 if exists($en_desc{$desc});
  %list = ();
  $match = 0;
  print "HU-" if $hu;
  print "DESCRIPTOR: '$desc' TH: ";
  if (exists($thesa{$desc})) {
    print "'", join("/",@{$thesa{$desc}}), "'";
  } else {
    print "NO THESAURUS!";
  }
  print " - HU but no EN - " if ($hu and !$en);
  print " - EN but no HU - " if ($en and !$hu);
  print "\n";
  
  # 0. Print out trained assoc list from trained data:
  if ($hu) {
    foreach my $word (sort keys %{$hu_desc{$desc}}) {
      print "0-ASSOC:: $word\t$hu_desc{$desc}{$word}\n";
    }
  }
  
  # 1. Print out hand translated data:
  if ($en) {
    foreach my $word (sort keys %{$en_desc{$desc}}) {
      print "1-ASSOC(e=$word):: ";
      if (exists($hand_en_hu{$word})) {
	print "$hand_en_hu{$word}\t$en_desc{$desc}{$word}\n";
      } else {
	print "NO TRANSLATION!\t$en_desc{$desc}{$word}\n";
      }
    }
  }

  # 2. Print out machine translated data. Weight: each HU equivalent gets the weight
  # of original EN/DE/FR word in anon array [HU_EQ,WEIGHT]. When all HU_EQ is collected,
  # weight is normalized w.r.t. frequency of occurence in translation list.
  
  # Get celex data if needed:
  $celex_string = get_celex($desc) if $Opt{'a'};
  print "CELEX: '$celex_string'\n" if $debug;

  # Process translation data:
  # trans_eq() gives back list of references to anon array: [$hu_eq,$weight]
  foreach my $trans (trans_eq(\%en_desc,\%en_hu,$desc),
		    trans_eq(\%de_desc,\%de_hu,$desc),
		    trans_eq(\%fr_desc,\%fr_hu,$desc)) {
    $list{$trans->[0]}{'freq'}++;
    $list{$trans->[0]}{'weight'} += $trans->[1];
  }

  foreach my $token (sort { $list{$b} <=> $list{$a} } keys %list) {
    my $print = 0;
    if ($Opt{'a'}) {
      # check match in actual CELEX text
      # replace spaces with regexp
      my $tomatch =  quotemeta($token);
      $tomatch =~ s/ /\\s+/g;
      if ($celex_string =~ m%\b$tomatch\b%) {
	$print = 1 if $list{$token}{'freq'} >= $threshold;
	print "2-MATCH: '$tomatch'=>'$&'\n";
      }
      if ($Opt{'o'}) {
	$print = 1 if $list{$token}{'freq'} >= $threshold;
      }
    } else {
      # simple freq threshold only
      $print = 1 if $list{$token}{'freq'} >= $threshold;
    }
    my $weight = $list{$token}{'weight'} / $list{$token}{'freq'};
    print "2-ASSOC(f=$list{$token}{'freq'}):: $token\t$weight\n" if $print;
  }

  print "===============\n";

}

print STDERR "$count descriptors processed.\n";

######################################################
##################### subs ###########################
######################################################

sub get_celex {
  # prepare long string from HU celex files
  my $desc = shift;
  my $string = '';
  foreach my $id (keys %{$celex_desc{$desc}}) {
    foreach my $file (<$celex_dir/*$id-HUc.xml>) {
      print "$file matched and can be opened\n" if $debug;
      $string = join(' ', $string,  make_string($file));
    }
  }
  return $string;
}

sub make_string {
  my $file = shift;
  my $string;
  open(CEL,"<$file") or die "Can't open $file $!";
  my $l = 0;
  while (<CEL>) {
    $l = 1 if /<lemmatised/;
    $l = 0 if /<\/lemmatised>/;
    # skip tags
    next if /<.*>/;
    next unless $l;
    chomp;
    $string .= " $_";
  }
  close(CEL);
  return $string;
}

sub trans_eq {
  # give back HU translist for descriptor in hash
  my ($href,$tref,$desc) = @_;
  my @trans;
  # for each associate:
  foreach my $word (keys %{$href->{$desc}}) {
    # add each HU trans
    foreach my $hu_eq (keys %{$tref->{$word}}) {
      print "Adding for WORD: '$word' -> HU_EQ: '$hu_eq' WEIGHT: '$href->{$desc}{$word}'\n"
	if $debug;
      push @trans, [ $hu_eq, $href->{$desc}{$word} ];
    }
  }
  return @trans;
}

sub read_desc {
  my $desc = shift;
  my ($dref,$file);
  if ($desc eq 'EN') {
    $dref = \%en_desc;
    $file = $endesc;
  }
  elsif ($desc eq 'DE') {
    $dref = \%de_desc;
    $file = $dedesc;
  }
  elsif ($desc eq 'FR') {
    $dref = \%fr_desc;
    $file = $frdesc;
  }
  elsif ($desc eq 'HU') {
    $dref = \%hu_desc;
    $file = $hudesc;
  } else {
    die "No descriptor file of $desc kind, exiting ...\n";
  }
  open("DESC","<$file") or die "Can't open $file $!";

  print STDERR "Processing $file ...\n";
  while (<DESC>) {
    # skip anything but descriptor line
    next unless /^[0-9]/;
    chomp;
    my ($id,$token,$weight) = split(/\t/,$_);
    $weight =~ s/,/./;
    # store descriptor as a hub for later processing
    $desc{$id}++;
    $token =~ s/_/ /g;
    $token =~ s/^\s+//;
    $token =~ s/\s+$//;
    print STDERR "Empty token for $id!\n" unless $token =~ /\w/;
    print STDERR "$desc: Added T:'$token' for ID:'$id'\n" if $debug;
    $$dref{$id}{$token}= $weight;
  }
  print_out($dref,$desc) if $debug;
}

sub read_tr {
  my $tr = shift;
  my ($trref,$file);
  if ($tr eq 'DE') {
    $trref = \%de_hu;
    $file = $detrans;
  } elsif ($tr eq 'FR') {
    $trref = \%fr_hu;
    $file = $frtrans;
  } else {
    die "No dictionary of $tr kind, exiting ...\n";
  }
  open("DIC","<$file") or die "Can't open $file $!";

  print STDERR "Processing $file ...\n";
  while (<DIC>) {
    # skip entry w.o. trans or spurious entry
    next if /=\s*$/ or /^\s/;
    chomp;
    $_ = clean_up($_);
    # regular processing for all dictionaries
    process_tr($trref,$_,$tr);
  }

  print_out($trref,$tr) if $debug;
}

sub process_tr {
  my ($href,$string,$tr) = @_;
  my ($foreign,$hu) = split(/=/,$string);
  foreach my $hunw (split(/,/,$hu)) {
    add_entry($href,$foreign,$hunw,$tr);
  }
}

sub add_entry {
  my ($href,$enw,$hunw,$tr) = @_;
  unless ($hunw =~ /unknown/) {
    print STDERR "Added HU:'$hunw' for $tr:'$enw'\n" if $debug;
    $$href{$enw}->{$hunw}++;
  }
}

sub print_out {
  # print out TR/DESC hash
  my ($href,$tr) = @_;
  foreach my $enw (keys %$href) {
    print "$tr:'$enw' HU:";
    print join(",",keys %{$href->{$enw}}), "\n";
  }
}

sub clean_up {
  my $s = 0;
  my $string = shift;
  $string =~ s/\s+=/=/;
  # delete ' ()' or '() ' regoins, they provide only domain info
  $string =~ s/ \(.*?\)//g;
  $string =~ s/\(.*?\) //g;
  # duplicate remaining '()' entries
  ##print STDERR "B: '$string'\n" if $string =~ /\(/;
  # delete '()' region if it includes ',' or '-' for simplicity...
  $string =~ s/\([^\)]*[-,][^\)]*\)//g and $s = 1 ;
  # in the middle
  $string =~ s/([,=])(\w+)\((\w+?)\)(\w+)\s*(?=,|\+|$)/$1$2$3$4,$2$4/g and $s = 1 ;
  # at the beginning
  $string =~ s/\((\w+?)\)(\w+)\s*(?=,|\+|$)/$1$2,$2/g and $s = 1 ;
  # end
  $string =~ s/(\w+)\((\w+?)\)\s*(?=,|\+|$)/$1$2,$1/g and $s = 1 ;
  # delete the rest
  $string =~ s/\([^,+\)]+\)?//g and $s = 1;
  $string =~ s/(,|\s+)$//;
  $string =~ s/\s+,/,/g;
  $string =~ s/,\s+/,/g;
  ##print STDERR "A: '$string'\n-------------------\n" if $s;
  return $string;
}

sub clean_token {
  my $token = shift;
  $token =~ s/_/ /g;
  $token =~ s/^\s+//;
  $token =~ s/\s+$//;
  print STDERR "Empty token in $.\n" unless $token =~ /\w/;
  return $token;
}
__END__

