######################################################################################
#     File WER_01.pl
#
#     TC-STAR project, n°FP6-506738
#
##### HISTORIC
#
#     version 01 : 05/03/29
#
#     Created the 05/03/29 - Olivier Hamon, ELDA
#
##### DESCRIPTION
#
#	Compute the Word Error Rate
#
##### USAGE
#
#	Input : - reference file
#		- source file
#		- test file
#	Output : scoring
#
#(C) Copyright ELDA 2005 All Rights Reserved.
#######################################################################################
use strict;

#print "command line:  ", $0, " ", join(" ", @ARGV), "\n";
my $usage = "\n\nUsage: $0 [-h] -r ref_file -t <tst_file>\n\n".
    "Description:  This Perl script evaluates MT system performance.\n".
    "\n".
    "Required arguments:\n".
    "  -r <ref_file> is a file containing the reference translations for\n".
    "      the documents to be evaluated.\n".
    "  -s <src_file> is a file containing the source documents for which\n".
    "      translations are to be evaluated\n".
    "  -t <tst_file> is a file containing the translations to be evaluated\n".
    "\n".
    "Optional arguments:\n".
    "  -c preserves upper-case alphabetic characters\n".
    "  -h prints this help message to STDOUT\n".
    "\n";

use vars qw ($opt_r $opt_s $opt_t $opt_d $opt_h $opt_c);
use Getopt::Std;
getopts ('r:s:t:h:c');
die $usage if defined($opt_h);
die "Error in command line:  ref_file not defined$usage" unless defined $opt_r;
die "Error in command line:  src_file not defined$usage" unless defined $opt_s;
die "Error in command line:  tst_file not defined$usage" unless defined $opt_t;
my $max_Ngram = 9;

my $preserve_case = defined $opt_c ? 1 : 0;

my ($ref_file) = $opt_r;
my ($src_file) = $opt_s;
my ($tst_file) = $opt_t;

######
# Global variables
my ($src_lang, $tgt_lang, @tst_sys, @ref_sys); # evaluation parameters
my (%tst_data, %ref_data); # the data -- with structure:  {system}{document}[segments]
my ($src_id, $ref_id, $tst_id); # unique identifiers for ref and tst translation sets
my %eval_docs;     # document information for the evaluation data set
my %ngram_info;    # the information obtained from (the last word in) the ngram

######
# Get source document ID's
($src_id) = get_source_info ($src_file);

######
# Get reference translations
($ref_id) = get_MT_data (\%ref_data, "RefSet", $ref_file);

######
# Get translations to evaluate
($tst_id) = get_MT_data (\%tst_data, "TstSet", $tst_file);

######
# Check data for completeness and correctness
check_MT_data ();

######
# Evaluate
#print "  Evaluation of $src_lang-to-$tgt_lang translation using:\n";
my $cum_seg = 0;
foreach my $doc (sort keys %eval_docs) {
    $cum_seg += @{$eval_docs{$doc}{SEGS}};
}
#print "    src set \"$src_id\" (", scalar keys %eval_docs, " docs, $cum_seg segs)\n";
#print "    ref set \"$ref_id\" (", scalar keys %ref_data, " refs)\n";
#print "    tst set \"$tst_id\" (", scalar keys %tst_data, " systems)\n\n";

foreach my $sys (sort @tst_sys) {
	my $score = score_system ($sys);
      #printf "\nWER score = %.4f for system \"$sys\"\n",$score;
      print $score;
}

exit 0;

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

sub get_source_info {

    my ($file) = @_;
    my ($name, $id, $src, $doc);
    my ($data, $tag, $span);
    

#read data from file
    open (FILE, $file) or die "\nUnable to open translation data file '$file'", $usage;
    $data .= $_ while <FILE>;
    close (FILE);

#get source set info
    die "\n\nFATAL INPUT ERROR:  no 'src_set' tag in src_file '$file'\n\n"
	unless ($tag, $span, $data) = extract_sgml_tag_and_span ("SrcSet", $data);

    die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n"
	unless ($id) = extract_sgml_tag_attribute ($name="SetID", $tag);

    die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n"
	unless ($src) = extract_sgml_tag_attribute ($name="SrcLang", $tag);
    die "\n\nFATAL INPUT ERROR:  $name ('$src') in file '$file' inconsistent\n"
	."                    with $name in previous input data ('$src_lang')\n\n"
	    unless (not defined $src_lang or $src eq $src_lang);
    $src_lang = $src;

#get doc info -- ID and # of segs
    $data = $span;
    while (($tag, $span, $data) = extract_sgml_tag_and_span ("Doc", $data)) {
	die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n"
	    unless ($doc) = extract_sgml_tag_attribute ($name="DocID", $tag);
	die "\n\nFATAL INPUT ERROR:  duplicate '$name' in file '$file'\n\n"
	    if defined $eval_docs{$doc};
	$span =~ s/[\s\n\r]+/ /g;  # concatenate records
	my $jseg=0, my $seg_data = $span;
	while (($tag, $span, $seg_data) = extract_sgml_tag_and_span ("Seg", $seg_data)) {
	    ($eval_docs{$doc}{SEGS}[$jseg++]) = NormalizeText ($span);
	}
	die "\n\nFATAL INPUT ERROR:  no segments in document '$doc' in file '$file'\n\n"
	    if $jseg == 0;
    }
    die "\n\nFATAL INPUT ERROR:  no documents in file '$file'\n\n"
	unless keys %eval_docs > 0;
    return $id;
}

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

sub get_MT_data {

    my ($docs, $set_tag, $file) = @_;
    my ($name, $id, $src, $tgt, $sys, $doc);
    my ($tag, $span, $data);

#read data from file
    open (FILE, $file) or die "\nUnable to open translation data file '$file'", $usage;
    $data .= $_ while <FILE>;
    close (FILE);

#get tag info
    while (($tag, $span, $data) = extract_sgml_tag_and_span ($set_tag, $data)) {
	die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n" unless
	    ($id) = extract_sgml_tag_attribute ($name="SetID", $tag);

	die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n" unless
	    ($src) = extract_sgml_tag_attribute ($name="SrcLang", $tag);
	die "\n\nFATAL INPUT ERROR:  $name ('$src') in file '$file' inconsistent\n"
	    ."                    with $name of source ('$src_lang')\n\n"
		unless $src eq $src_lang;
	
	die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n" unless
	    ($tgt) = extract_sgml_tag_attribute ($name="TrgLang", $tag);
	die "\n\nFATAL INPUT ERROR:  $name ('$tgt') in file '$file' inconsistent\n"
	    ."                    with $name of the evaluation ('$tgt_lang')\n\n"
		unless (not defined $tgt_lang or $tgt eq $tgt_lang);
	$tgt_lang = $tgt;

	my $mtdata = $span;
	while (($tag, $span, $mtdata) = extract_sgml_tag_and_span ("Doc", $mtdata)) {
	    die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n" unless
		(my $sys) = extract_sgml_tag_attribute ($name="SysID", $tag);
	    
	    die "\n\nFATAL INPUT ERROR:  no tag attribute '$name' in file '$file'\n\n" unless
		$doc = extract_sgml_tag_attribute ($name="DocID", $tag);
	    
	    die "\n\nFATAL INPUT ERROR:  document '$doc' for system '$sys' in file '$file'\n"
		."                    previously loaded from file '$docs->{$sys}{$doc}{FILE}'\n\n"
		    unless (not defined $docs->{$sys}{$doc});

	    $span =~ s/[\s\n\r]+/ /g;  # concatenate records
	    my $jseg=0, my $seg_data = $span;
	    while (($tag, $span, $seg_data) = extract_sgml_tag_and_span ("Seg", $seg_data)) {
		($docs->{$sys}{$doc}{SEGS}[$jseg++]) = NormalizeText ($span);
	    }
	    die "\n\nFATAL INPUT ERROR:  no segments in document '$doc' in file '$file'\n\n"
		if $jseg == 0;
	    $docs->{$sys}{$doc}{FILE} = $file;
	}
    }
    return $id;
}

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

sub check_MT_data {

    @tst_sys = sort keys %tst_data;
    @ref_sys = sort keys %ref_data;

#every evaluation document must be represented for every system and every reference
    foreach my $doc (sort keys %eval_docs) {
	my $nseg_source = @{$eval_docs{$doc}{SEGS}};
	foreach my $sys (@tst_sys) {
	    die "\n\nFATAL ERROR:  no document '$doc' for system '$sys'\n\n"
		unless defined $tst_data{$sys}{$doc};
	    my $nseg = @{$tst_data{$sys}{$doc}{SEGS}};
	    die "\n\nFATAL ERROR:  translated documents must contain the same # of segments as the source, but\n"
		."              document '$doc' for system '$sys' contains $nseg segments, while\n"
                ."              the source document contains $nseg_source segments.\n\n"
		    unless $nseg == $nseg_source;
	}

	foreach my $sys (@ref_sys) {
	    die "\n\nFATAL ERROR:  no document '$doc' for reference '$sys'\n\n"
		unless defined $ref_data{$sys}{$doc};
	    my $nseg = @{$ref_data{$sys}{$doc}{SEGS}};
	    die "\n\nFATAL ERROR:  translated documents must contain the same # of segments as the source, but\n"
		."              document '$doc' for system '$sys' contains $nseg segments, while\n"
                ."              the source document contains $nseg_source segments.\n\n"
		    unless $nseg == $nseg_source;
	}
    }
}

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

sub score_system {

    	my ($sys) = @_;
	my $distance_sys = 0;
	my $longueur_moyenne_sys = 0;
	my ($distance_doc, $longueur_moyenne_doc);

    	foreach my $doc (sort keys %eval_docs) {
		($distance_doc, $longueur_moyenne_doc) = score_document ($sys, $doc);

		$distance_sys += $distance_doc;
		$longueur_moyenne_sys += $longueur_moyenne_doc;
	}

	my $score_sys = ($distance_sys / $longueur_moyenne_sys) * 100;

	return $score_sys;
}

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

sub score_document {

    	my ($sys, $doc) = @_;
    	my $distance_doc = 0;
	my $longueur_moyenne_doc = 0;
	my ($distance_segment, $longueur_moyenne_ref);
    
	#score each segment
    	for (my $jseg=0; $jseg<@{$tst_data{$sys}{$doc}{SEGS}}; $jseg++) {
		my @ref_segments = ();
		foreach my $ref (@ref_sys) {
	    		push @ref_segments, $ref_data{$ref}{$doc}{SEGS}[$jseg];
		}
		($distance_segment, $longueur_moyenne_ref) = score_segment ($tst_data{$sys}{$doc}{SEGS}[$jseg], @ref_segments);

		$distance_doc += $distance_segment;
		$longueur_moyenne_doc += $longueur_moyenne_ref;
	}

    return ($distance_doc, $longueur_moyenne_doc);
}

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

sub score_segment {

    	my ($tst_seg, @ref_segs) = @_;
    	my $distance_segment;
    	my $longueur_moyenne_ref = 0;
	my @tst_wrds;
	my @ref_wrds;


# get the ngram counts for the test segment
    @tst_wrds = split /\s+/, $tst_seg;

# get the ngram counts for the reference segments
    foreach my $ref_seg (@ref_segs) {
	@ref_wrds = split /\s+/, $ref_seg;
	my $distance = Distance(\@ref_wrds, \@tst_wrds);
	$distance_segment = $distance # find the shortest reference segment
	    if (not defined $distance_segment) or $distance < $distance_segment;
	
	$longueur_moyenne_ref += scalar @ref_wrds;

    }

	$longueur_moyenne_ref /= scalar @ref_segs;

    return ($distance_segment, $longueur_moyenne_ref);
}

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

sub NormalizeText {
    my ($norm_text) = @_;

# language-independent part:
    $norm_text =~ s/<skipped>//g; # strip "skipped" tags
    $norm_text =~ s/-\n//g; # strip end-of-line hyphenation and join lines
    $norm_text =~ s/\n/ /g; # join lines
    $norm_text =~ s/(\d)\s+(\d)/$1$2/g; #join digits
    $norm_text =~ s/&quot;/"/g;  # convert SGML tag for quote to "
    $norm_text =~ s/&amp;/&/g;   # convert SGML tag for ampersand to &
    $norm_text =~ s/&lt;/</g;    # convert SGML tag for less-than to >
    $norm_text =~ s/&gt;/>/g;    # convert SGML tag for greater-than to <

# language-dependent part (assuming Western languages):
    $norm_text = " $norm_text ";
    $norm_text =~ tr/[A-Z]/[a-z]/ unless $preserve_case;
    $norm_text =~ s/([\{-\~\[-\` -\&\(-\+\:-\@\/])/ $1 /g;   # tokenize punctuation
    $norm_text =~ s/([^0-9])([\.,])/$1 $2 /g; # tokenize period and comma unless preceded by a digit
    $norm_text =~ s/([\.,])([^0-9])/ $1 $2/g; # tokenize period and comma unless followed by a digit
    $norm_text =~ s/([0-9])(-)/$1 $2 /g; # tokenize dash when preceded by a digit
    $norm_text =~ s/\s+/ /g; # one space only between words
    $norm_text =~ s/^\s+//;  # no leading space
    $norm_text =~ s/\s+$//;  # no trailing space

    return $norm_text;
}

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

sub extract_sgml_tag_and_span {
    
    my ($name, $data) = @_;
    
    ($data =~ m|<$name\s*([^>]*)>(.*?)</$name\s*>(.*)|si) ? ($1, $2, $3) : ();
}

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

sub extract_sgml_tag_attribute {

    my ($name, $data) = @_;

    ($data =~ m|$name\s*=\s*\"([^\"]*)\"|si) ? ($1) : ();
}

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

sub Distance
{
	my ($tab1, $tab2) = @_;
	my @chaine1 = @$tab1;
	my @chaine2 = @$tab2;

	my $taille1=@chaine1;
	my $taille2=@chaine2;
	my @matrice;
	
	if ($taille1 eq 0)
	{
		return $taille2;
	}
	elsif ($taille2 eq 0)
	{
		return $taille1;
	}

	for (my $i = 0; $i <= $taille1;$i++)
	{
		$matrice[$i][0] = $i;
	}
	for (my $i = 0; $i <= $taille2;$i++)
	{
		$matrice[0][$i] = $i;
	}

	my $mot1;
	my $mot2;
	my $cout;
	for (my $i = 1; $i <= $taille1; $i++)
	{
		$mot1 = $chaine1[$i-1];
		for (my $j = 1; $j <= $taille2; $j++)
		{
			$mot2 = $chaine2[$j-1];

			if ($mot1 eq $mot2)
			{
				$cout = 0;
			}
			else
			{
				$cout = 1;
			}

			$matrice[$i][$j] = Min($matrice[$i-1][$j]+1, $matrice[$i][$j-1]+1, $matrice[$i-1][$j-1]+$cout);
		}
	}

	return ($matrice[$taille1][$taille2]);
}

sub Min
{
	my ($prems, $deuz, $troiz) = @_;

	my $renvoi = $prems;
	if ($deuz < $renvoi)
	{
		$renvoi = $deuz;
	}
	if ($troiz < $renvoi)
	{
		$renvoi = $troiz;
	}

	return $renvoi;
}
