#!/usr/bin/perl -w

use strict;


# Author: Hoa Dang (hoa.dang@nist.gov)
#
# Date: August 28, 2013
# Version 1.0
# Initial version
# Adapted from check_kbp_slot-filling.pl Version 2.2

# Check a TAC 2013 KBP sentiment slot-filling track submission for various common errors, including:
#		* invalid run tag (should be a concatenation of your TAC 2013 team ID and the run number (1-5)
#		* multiple run tags
#		* invalid query id or slot name
#		* missing value for a query (at least one response required per query)
#		* answer from an invalid document
#		* offsets (Columns 6,7,8) that appear to be invalid
#		* the confidence score must be a double value less or equal to 1
# Messages regarding submission are printed to an error log

# Usage is:
#    check_kbp_sentiment-slot-filling.pl doclist_file queries_file results_file
#  where results_file is the name of the results submission file to be checked

# The doclist file lists all the valid document IDS for the task, one ID per line
#
# The queries file is an xml file with the following dtd
#   <!ELEMENT kbpslotfill (query+)>
#   <!ELEMENT query   (name, docid, beg, end, enttype, nodeid, slot)>
#   <!ELEMENT name   (#PCDATA)>
#   <!ELEMENT docid   (#PCDATA)>
#   <!ELEMENT beg   (#PCDATA)>
#   <!ELEMENT end   (#PCDATA)>
#   <!ELEMENT enttype (#PCDATA)>
#   <!ELEMENT nodeid (#PCDATA)>
#   <!ELEMENT slot (#PCDATA)>
#   <!ATTLIST query id ID #REQUIRED>
#
# The results file has at least one response for each query
#
# A response is a line with the following tab-separated columns:
# Column 1: query id
# Column 2: slot name
# Column 3: a unique run id for the submission
# Column 4: NIL, if the system believes no information is learnable for this slot; or a single docid
# that justifies the relation between the query entity and the slot filler
# Column 5: a slot filler
# Column 6: start-end offsets for representative mentions used to extract/normalize filler
# Column 7: start-end offsets for representative mentions used to extract/normalize query entity
# Column 8: start-end offsets of clause(s)/sentence(s) in justification
# Column 10: confidence score
#
# If Column 4 is NIL, then Columns 5-10 must be empty.
# The slot filler (Column 5) must not contain any embeded tab characters

# This script also creates a new file, "input", in the current directory
# that has a more standard format (there will not be leading whitespace;
# and columns will be separated by one tab)


# Change this variable to the directory where the error log should be put
my $errlog_dir = ".";

my $MAX_ERRORS = 2500;

my %queries;

# Slot names and filler types as defined in LDC publication "TAC KBP Sentiment Slot Filling Guidelines"; Version 1.0; July 29, 2013
# This variable is not used by the script and is for documentation purposes only
my %slots = ('PER' => {'per:pos-from' => {quantity => 'list',
				    content => 'name'}, 
		       'per:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'per:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'per:pos-towards' => {quantity => 'list',
				    content => 'name'}, 
		       'per:neg-towards' => {quantity => 'list',
				    content => 'name'}},
	     'ORG' => {'org:pos-from' => {quantity => 'list',
				    content => 'name'}, 
		       'org:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'org:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'org:pos-towards' => {quantity => 'list',
				    content => 'name'}, 
		       'org:neg-towards' => {quantity => 'list',
				    content => 'name'}},
	     'GPE' => {'gpe:pos-from' => {quantity => 'list',
				    content => 'name'}, 
		       'gpe:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'gpe:neg-from' => {quantity => 'list',
				    content => 'name'}, 
		       'gpe:pos-towards' => {quantity => 'list',
				    content => 'name'}, 
		       'gpe:neg-towards' => {quantity => 'list',
				    content => 'name'}});

my $doclist_file;               # list of valid docids
my $queries_file;               # list of eval queries
my $results_file;		# submission file to check/validate
my %docids;                     # list of valid docids
my %qids;			# number of answers returned for query
my %nils;                       # number of NIL answers returned for query
my ($errlog,$num_errors,$line_num,$num_warnings);
my ($run_id, $tag);
my ($q,$etype,$qslot,$slot_name,$docid, $answer,$fillerOffsets, $entityOffsets, $justOffsets, $conf);
my ($i, $last_i, $line);

if ($#ARGV != 2) {
    print STDERR "Usage: $0 doclist_file query_file resultsfile\n";
    die "\n";
}

$doclist_file = $ARGV[0];
$queries_file = $ARGV[1];
$results_file = $ARGV[2];
$num_errors = 0;
$num_warnings = 0;

# set up output files 
$last_i = -1;
while ( ($i=index($results_file,"/",$last_i+1)) > -1) {
    $last_i = $i;
}
$errlog = $errlog_dir . "/" . substr($results_file,$last_i+1) . ".errlog";
open ERRLOG, ">$errlog" ||
	die "Cannot open error log for writing\n";

open INPUT, ">input"   || die "Cannot create `input' file: $!\n";


# read in doclist file
open DOCLIST, "<$doclist_file" ||
    die "Unable to open document list file $doclist_file: $!";
while ($line = <DOCLIST>) {
    chomp $line;
    $docids{$line} = 1;
}

# read in queries file
# only do limited error checking
open QUERIES, "<$queries_file" ||
    die "Unable to open queries file $queries_file: $!";
undef $q;
undef $etype;
undef $qslot;
while ($line = <QUERIES>) {
    chomp $line;
    next if ($line =~ /^\s*$/);
    $line =~ s/^\s*(.*\S)\s*$/$1/g; # remove leading and trailing whitespace
    if($line =~/^<query\s+id\s*=\s*"([^"]+)"\s*>$/) {
	$q= $1;
	if (defined $queries{$q}) {
	    &error("duplicate query ids in queries file");
	    next;
	}
    } elsif ($line =~ /^<\/query>$/) {
	if (!defined $etype) {
	    &error("undefined enttype for query $q");
	    next;
	}
	if (!defined $qslot) {
	    &error("undefined slot for query $q");
	    next;
	}
	
	$queries{$q}{'type'} = $etype;
	$queries{$q}{'slot'} = $qslot;
	undef $q;
	undef $etype;
	undef $qslot;
    } elsif ($line =~ /^<enttype>([A-Z]+)<\/enttype>$/) {
	if((defined $etype)) {
	    &error("entity type $etype already defined");
	    next;
	}
	$etype = $1;
    } elsif ($line =~ /^<slot>([-a-z]+)<\/slot>$/) {
	if ((defined $qslot)) {
	    &error("slot $qslot already defined for query $q");
	    next;
	}
	$qslot = $1;
    }
}


open RESULTS, "<$results_file" ||
    die "Unable to open results file $results_file: $!";
$line_num = 0;
$run_id = "";
while ($line = <RESULTS>) {
    chomp $line;
    $line_num++;

    next if ($line =~ /^\s*$/);

# Disabled UTF8 checking. This code is not robust!
#    if (&invalid_UTF8($line)) {
#		&error("invalid character (non-UTF8)");
#		next;
#    }

    undef $slot_name;
    undef $tag;
    undef $docid;
    undef $answer;
    undef $fillerOffsets;
    undef $entityOffsets;
    undef $justOffsets;
    undef $conf;
    ($q, $slot_name, $tag, $docid, $answer, $fillerOffsets, $entityOffsets, $justOffsets, $conf) = split "\t", $line, 9;
    
    if (!defined $docid || length($docid) == 0 || !defined $tag || !defined $slot_name) {
		&error("Wrong number of fields -- missing fields");
		next;
    }
	
    # make sure runtag is ok
    if (! $run_id) { 	# very first line --- remember tag 
		$run_id = $tag;
        if ($run_id !~ /^[A-Za-z0-9._]{1,12}[1-5]$/) {
            &error("Run tag `$run_id' is malformed)");
            next;
        }
    }
    else {			# otherwise just make sure one tag used
		if ($tag ne $run_id) {
	    	&error("Run tag inconsistent (`$tag' and `$run_id')");
	    	next;
		}
    }

    # get query id
    if (!defined $queries{$q}) {
   		&error("Invalid query id ($q)");
		next;
    }
    # make sure slot name is the same as the slot requested in the query
    if ($queries{$q}{'slot'} ne $slot_name) {
	   	&error("Invalid slot name $slot_name for query $q");
		next;
    }

    $qids{$q}{$slot_name}++;

    if ($docid ne "NIL") {

		if (!defined($conf)) {
	    	&error("Wrong number of fields -- missing fields");
	    	next;
		}
	
		# make sure docid valid
        if ($docid =~ /(\.sgm)/) {
	    	&error("Unknown document ID `$docid' (looks like a file name instead of a document ID)");
            next;
		} elsif (!$docids{$docid}) {
	    	&error("Unknown document `$docid'");
            next;
        }

		# make sure answer exists
        if (!defined $answer || length($answer) == 0) {
	    	&error("Missing answer-string for slot $slot_name for query $q");
	    	next;
       	}

		# check filler offsets and justification offsets
		my $checkMsg = &checkOffsets($justOffsets, 2, $slot_name);
		if(length($checkMsg) > 0) {
		    &error("invalid justification offsets: `$justOffsets' ($checkMsg)");
		    next;
		}
		$checkMsg = &checkOffsets($fillerOffsets, 2, "");
		if(length($checkMsg) > 0) {
		    &error("invalid filler offsets: `$fillerOffsets' ($checkMsg)");
		    next;
		} else {
			if(&offsetInclusion($justOffsets, $fillerOffsets) == 0) {
				&warn("Filler offsets $fillerOffsets not included in justification offsets $justOffsets. This is not necessarily an error but it is not common.");
			}
		}
		$checkMsg = &checkOffsets($entityOffsets, 2, $slot_name);
		if(length($checkMsg) > 0) {
		    &error("invalid entity offsets: `$entityOffsets' ($checkMsg)");
		    next;
		} else {
			if(&offsetInclusion($justOffsets, $entityOffsets) == 0) {
				&warn("Entity offsets $entityOffsets not included in justification offsets $justOffsets. This is not necessarily an error but it is not common.");
			}
		}

		# make sure the confidence is a double with a valid value
		if(!($conf =~ /^\d+\.\d+$/ && $conf <= 1.0)) {
	    	&error("invalid confidence value `$conf'");
	    	next;
		}

		print INPUT "$q\t$slot_name\t$tag\t$docid\t$answer\t$fillerOffsets\t$entityOffsets\t$justOffsets\t$conf\n";

    } else {
		if ($answer) {
	    	&error ("Answer string given when docid is NIL");
	    	next;
		}
		$answer = "";
		$nils{$q}{$slot_name}++;

	    print INPUT "$q\t$slot_name\t$tag\t$docid\n";
    }

}


# Do global checks:
#   error if some query has no response given for it
#   error if more than one response is given for a query where NIL has been given as an answer
foreach $q (keys %queries) {
    $slot_name = $queries{$q}{'slot'};
    if (! defined $qids{$q}{$slot_name}) {
	&error("No response given for slot $slot_name for query $q");
    }
    if (defined $qids{$q}{$slot_name} && $qids{$q}{$slot_name} > 1 && defined $nils{$q}{$slot_name}) {
	&error("More than one response given for slot $slot_name for query $q, where NIL has been given as an answer");
    }
}
print ERRLOG "Finished processing $results_file\n";

close INPUT || die "Close failed for `input' file: $!\n";
close ERRLOG || die "Close failed for error log $errlog: $!\n";
if ($num_errors) { exit 255; }
exit 0;

# checks offsets for filler, entity, or justification
# it makes sure that:
#	no more than N pairs are given
#	each offset is an integer value
#	each end offset is larger than the corresponding start
sub checkOffsets {
	my $slotName = pop(@_);
	my $N = pop(@_);
	my $offsetString = pop(@_);

	my @tokens = split(',', $offsetString);

	# at least an offset pair must be present if not alternate_name
	if($slotName ne "per:alternate_names" && $slotName ne "org:alternate_names") {
		if($#tokens < 0) {
			return "At least 1 offset pair must be present!";
		}
	}	

	# at most $N tokens accepted
	if($#tokens >= $N) {
		return "At most $N offset pairs accepted!";
	}

	# check each offset pair given
	foreach my $pair (@tokens) {
		(my $start, my $end) = split('\-', $pair, 2);
		if(!($start =~ /^\d+$/)) {
			return "Start offset $start must be a positive integer value!";
		}
		if(!($end =~ /^\d+$/)) {
			return "End offset $end must be a positive integer value!";
		}
		if($end < $start) {
			return "End offset $end is smaller than start offset $start!";
		}
	}

	return "";
}

sub offsetInclusion {
	my $offsetString = pop(@_);
	my $justOffsetString = pop(@_);

	my @offsets = extractOffsets($offsetString);
	my @justOffsets = extractOffsets($justOffsetString);

	# some of these offsets may not be present. this is ok
	if($#offsets == -1 or $#justOffsets == -1) {
		return 1;
	}

	for(my $i = 0; $i < $#offsets; $i += 2) {
		my $start = $offsets[$i];
		my $end = $offsets[$i + 1];

		for(my $j = 0; $j <= $#justOffsets; $j += 2) {
			my $sj = $justOffsets[$j];
			my $ej = $justOffsets[$j + 1];
			if($start >= $sj && $end <= $ej) {
				return 1;
			}
		}
	}	

	return 0;
}

sub extractOffsets {
	my $offsetString = pop(@_);
	my @tokens = split(',', $offsetString);
	my @offsets = ();
	foreach my $pair (@tokens) {
		(my $start, my $end) = split('\-', $pair, 2);
		push(@offsets, $start);
		push(@offsets, $end);
	}
	# print "OFFSETS: @offsets\n";
	return @offsets;
}

 # print error message, keeping track of total number of errors
sub error {
   my $msg_string = pop(@_);

    print ERRLOG 
    "$0 of $results_file: Error on line $line_num --- $msg_string\n";

    $num_errors++;
    if ($num_errors > $MAX_ERRORS) {
        print ERRLOG "$0 of $results_file: Quit. Too many errors!\n";
        close ERRLOG ||
		die "Close failed for error log $errlog: $!\n";
		exit 255;
    }
}

# print warning message, keeping track of total number of warnings
sub warn {
   my $msg_string = pop(@_);

    print ERRLOG 
    "$0 of $results_file: Warning on line $line_num --- $msg_string\n";

    $num_warnings++;
    # You can add stopping after N warnings here.
    # Currently, we do not stop because of warnings.
}

#  Returns index of string element in array if present, else -1
sub is_member {
    my($element,$arrayref) = @_;
 
    my $i;
    for ($i=0; $i<= $#{$arrayref}; $i++) {
        if ($element eq $$arrayref[$i]) {
            return($i);
        }
    }
    return(-1);
}  

# Return 0 iff line is valid UTF-8; else return 1.
# Regular expression from: http://www.w3.org/International/questions/qa-forms-utf-8
sub invalid_UTF8 {
    my ($line) = @_;
    if($line =~
       m/\A(
	    [\x09\x0A\x0D\x20-\x7E]            # ASCII
	    | [\xC2-\xDF][\x80-\xBF]             # non-overlong 2-byte
	    |  \xE0[\xA0-\xBF][\x80-\xBF]        # excluding overlongs
	    | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2}  # straight 3-byte
	    |  \xED[\x80-\x9F][\x80-\xBF]        # excluding surrogates
	    |  \xF0[\x90-\xBF][\x80-\xBF]{2}     # planes 1-3
	    | [\xF1-\xF3][\x80-\xBF]{3}          # planes 4-15
	    |  \xF4[\x80-\x8F][\x80-\xBF]{2}     # plane 16
	    )*\z/x) {
	return 0;
    } else {
	return 1;
    }
}
    
