#! /usr/bin/perl
#
# Read the text files from text files (defaults to ../Transcriptions)
# and calculate the Context Distinctiveness of the words.
# Store Tables in 
# ../../../DatabaseFiles/wordlists/
#
# Use: 
# ConstructContextDistinctivenessTables <filename1> <filename2> ...
#
###############################################################################
#
# Copyright R.J.J.H. van Son © 2000, 2001
#
# Author Rob van Son
# Institute of Phonetic Sciences & ACLC
# University of Amsterdam
# Herengracht 338
# NL-1016CG Amsterdam, The Netherlands
# Email: Rob.van.Son@hum.uva.nl
#        rob.van.son@workmail.com
# WWW  : http://www.fon.hum.uva.nl/rob/
# mail:  Institute of Phonetic Sciences
#        University of Amsterdam
#        Herengracht 338
#        NL-1016CG Amsterdam
#        The Netherlands
#        tel +31 205252183
#        fax +31 205252197
#
# License for use and disclaimers
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
#
#######################################################
#

$HomeDir = '../../..';
require "$HomeDir/Links.pl";
require "$Scripts/SplitText.pl";
require "$Scripts/SentenceLabel.pl";

my $Separator = '/';
my $DatabaseFiles = "$DatabaseTables/wordlists/";
my @DefaultPaths = ('../../../Transcriptions/*/????1VI*.txt', 
			'../../../Transcriptions/*/????1FR*.txt', 
			'../../../Transcriptions/*/????2VR*.txt', 
			'../../../home/POS/tags/*/????1VI*.tl',
			'../../../home/POS/tags/*/????1FR*.tl',
			'../../../home/POS/tags/*/????2VR*.tl',
			);
# Length of +/- window of words
my $WindowLength = 5;

# Allow partial tables for specific files
my $FilePrefix = '';
if(grep(/^-f$/, @ARGV))
{
	@ARGV = grep(!/^-f$/, @ARGV);
	$FilePrefix = "$ARGV[0]";
    $FilePrefix = $1 if $FilePrefix =~ /([\w\-]+)\.[^\.]*/i;
    print STDERR "@ARGV\n";
};

my $TableName = "${FilePrefix}ContextDist";

#
# Split a line of text into words
my $PunctuationChars = '(^|\s)[\,\:\;\`\'\-\"](\s|$)';
sub SplitIntoWords      # ($line) -> @LineOfWords;
{
    my $Line = shift || " ";
    
    my @LineOfWords = (" ");
    my @AllWords = ();
    
    # Empty line contains a single space
    return @LineOfWords unless $Line =~ /\S/;
    
    # Split line to words
    $Line =~ s/([\'\`]s)-/\1 /ig;
    $Line =~ s/([\'\`]s)\s+(morg|ocht|mid|avond|nacht|here|graven|hert)/\1\-\2/ig;
	$Line =~ s/[\.\,\?\!\:\;\"]/ /g;	# Remove all punctuation
    @LineOfWords = split(" ", $Line);
    
    while(@LineOfWords)
    {
        if($LineOfWords[0] =~ /\</)
        {
            # Brackets are currently removed
            my @Brackets = ();
            while($LineOfWords[0] !~ /\>/)
            { 
                push(@Brackets, shift(@LineOfWords));
            };
            push(@Brackets, shift(@LineOfWords));
        }
        else
        {
            push(@AllWords, $LineOfWords[0]);
            shift(@LineOfWords);
        };
    };
    
    return @AllWords;
};

# Fill a table with context distributions
my %PlainContextTable = ('!TYPE!' => 'Plain');
my %LemmaContextTable = ('!TYPE!' => 'Lemma');

sub FillContextTable	# (\%ContextTable, $Word, @Context)
{
	my $ContextTable = shift;
	my $Word = shift;
	my @Context = @_;

	++($$ContextTable{$Word}{'!COUNT!'});
	++($$ContextTable{'!TOTAL!'}{'!COUNT!'});
	my $ContextualWord;
	foreach $ContextualWord (@Context)
	{
		++($$ContextTable{$Word}{$ContextualWord});
		++($$ContextTable{$Word}{'!CONTEXTCOUNT!'});
	};
	
	# Ready
	return $ContextTable;
}

# Calculate relative frequencies
sub ContextTableFrequencies	# (\%ContextTable) -> \%ContextTableWithRelativeFrequencies
{
	my $ContextTable = shift;
	
	# Determine relative context frequencies
	$$ContextTable{'!TOTAL!'}{'!WORDFREQ!'} = 0;
	my $Word;
	foreach $Word (grep(!/\!/, keys(%{$ContextTable})))
	{
		# Determine word counts and related counts+1
		my $WordCount = $$ContextTable{$Word}{'!CONTEXTCOUNT!'};
		my $WordFreq = $WordCount + 1;
		$$ContextTable{'!TOTAL!'}{'!WORDFREQ!'} += $$ContextTable{$Word}{'!COUNT!'} + 1;
		
		# Get all the context words
		my $CurrentWordEntry = $ContextTable->{$Word};
		my @ContextList = grep(!/\!/, keys(%$CurrentWordEntry));
		my $ContextWord;
		foreach $ContextWord (@ContextList)
		{
			my $ContextFreq = $$ContextTable{$Word}{$ContextWord} + 1;
			$$ContextTable{$Word}{$ContextWord} = $ContextFreq/$WordFreq;
		};
	};
	
	# Calculate relative word frequencies
	return 0 unless $$ContextTable{'!TOTAL!'}{'!WORDFREQ!'} > 0;
	my $TotalWordFreq = $$ContextTable{'!TOTAL!'}{'!WORDFREQ!'};
	foreach $Word (grep(!/\!/, keys(%{$ContextTable})))
	{
		my $WordCount = $$ContextTable{$Word}{'!COUNT!'};
		my $WordFreq = $WordCount + 1;
		$$ContextTable{$Word}{'!RELFREQUENCY!'} = $WordFreq / $TotalWordFreq;
	};
	
	# Ready
	return $ContextTable;
}

# Calculate distinctiveness as the Kullback-Leiber 
# distances between P(context|word) and P(context)
sub ContextTableDistinctiveness	# (\%ContextTable) -> \%ContextTable
{
	my $ContextTable = shift;
		
	# Determine relative context frequencies
	my $Word;
	foreach $Word (grep(!/\!/, keys(%{$ContextTable})))
	{
		# Get all the context words
		my $CurrentWordEntry = $ContextTable->{$Word};
		my @ContextList = grep(!/\!/, keys(%$CurrentWordEntry));
		my $ContextWord;
		my $Distinctiveness = 0;
		foreach $ContextWord (@ContextList)
		{
			my $ContextWordRelFrequency = $$ContextTable{$Word}{$ContextWord};
			my $ContextRelFrequency = $$ContextTable{$ContextWord}{'!RELFREQUENCY!'};
			# Summ weighted contributions to Kullback-Leiber distance
			if($ContextWordRelFrequency > 0 && $ContextRelFrequency > 0)
			{
				# $Distinctiveness = Sum{P(ci|W)*log2(P(ci|W)/P(ci))}
				$Distinctiveness += $ContextWordRelFrequency 
				* (log($ContextWordRelFrequency) - log($ContextRelFrequency))
				/ log(2);
			};
		};
		$$ContextTable{$Word}{'!CONTEXTDISTINCTIVENESS!'} = $Distinctiveness;
	};
		
	# Ready
	return $ContextTable;
}

#
# The column headers and types
my @ColumnHeaders = (
'number [INT4] Ordinal number of word in list (a kind of ID)',
'word [TEXT] word value (text)',
'Frequency [INT4] Number of occurrences',
'RelFreq [FLOAT8] Relative Frequency (Count+1/(Number of words+Number of wordforms))',
'Info [FLOAT8] Information in bits, i.e., the logarithm (base 2) of the Relative Frequency',
'ContextDist [FLOAT8] Context distinctiveness as relative information (Kullback-Leiber distance between P(ci|W) and P(ci))',
'InfoDiff [FLOAT8] Difference Info - ContextDist = unique information in token'
);

# Make sure ARGV contains non-empty items
@ARGV = grep(/\S/, @ARGV);

# If @ARGV is empty, do all
@ARGV = @DefaultPaths unless @ARGV;

my $FileName = "";

# Handle all speakers in the arguments
foreach $FileName (@ARGV)
{
    # Get all files
    my @FileList = glob($FileName);

    # Get information
    my $FilePath;
    foreach $FilePath (@FileList)
    {
	
		my @PreviousWords = ();
		my $Word = "";
		my @NextWords = ();
		
		# POS files with Lemma's
		if($FilePath =~ /\.(pos|tl)$/i)
		{
			open(TEXTFILE, $FilePath) || die "$FilePath: $!\n";
			while(<TEXTFILE>)
			{
				# skip empty lines
				next unless /\S/;
				# skip <...>
				next if /^\s*\</ && /\>\s*$/;

				# Get the next lemma
				my @EntryLine = split;
				# Lemma is last entry
				my $Lemma = $EntryLine[2];
				# Take word if there is no Lemma
				$Lemma = $EntryLine[0] unless $Lemma =~ /[a-z]/i;
				# Skip punctuation
				next unless $Lemma =~ /[a-z]/i;

				# Process word
	    		# Skip non-words
	    		next unless $Lemma =~ /[a-z]/i;

				my $NextContextWord = lc($Lemma);
				next if $NextContextWord =~ /\*[ax]|xxx|ggg/i;

				# Clean word and add it to the list
				$NextContextWord =~ s/\*.*$//ig;
	    		push(@NextWords, $NextContextWord);
				push(@PreviousWords, $Word) if $Word;
				$Word = shift(@NextWords) if scalar(@NextWords) > $WindowLength;
				shift(@PreviousWords) if scalar(@PreviousWords) > $WindowLength;

				# Fill this word/context into the table
				FillContextTable(\%LemmaContextTable, $Word, @PreviousWords, @NextWords) if $Word; 

			};
			# File is processed, now handle remaining context in store
			# Empty @NextWords to get all the counts right
			while(@NextWords)
			{
				push(@PreviousWords, $Word) if $Word;
				$Word = shift(@NextWords);
				shift(@PreviousWords);

				# Fill this word/context into the table
				FillContextTable(\%LemmaContextTable, $Word, @PreviousWords, @NextWords) if $Word; 
			};
		}
		# Orthography
		elsif($FilePath =~ /\.ort$/i)
		{
			my $OrthographicTiers = new SentenceLabel;
			$OrthographicTiers->ReadLabelFile($FilePath);
			my $FirstTier = $OrthographicTiers->{'TIERORDER'}[0];
			$OrthographicTiers->presetItem($FirstTier);
			while($OrthographicTiers->nextItem($FirstTier) > -1)
			{
				my $Sentence = $OrthographicTiers->currentValue($FirstTier);
		    	# Cut sentence into single words (taking care of 's )
		    	my @WordSentence = SplitIntoWords($Sentence);

		    	# Fill tables
		    	my $i;
		    	for($i=0; $i < scalar(@WordSentence); ++$i)
		    	{
	    			# Skip non-words
	    			next unless $WordSentence[$i] =~ /[a-z]/i;
					my $NextContextWord = lc($WordSentence[$i]);

					next if $NextContextWord =~ /\*[ax]|xxx|ggg/i;
					$NextContextWord =~ s/\*.*$//ig;
	    				push(@NextWords, $NextContextWord);
					push(@PreviousWords, $Word) if $Word;
					$Word = shift(@NextWords) if scalar(@NextWords) > $WindowLength;
					shift(@PreviousWords) if scalar(@PreviousWords) > $WindowLength;

					# Fill this word/context into the table
					FillContextTable(\%PlainContextTable, $Word, @PreviousWords, @NextWords) if $Word; 
		    	};
			};
			# File is processed, now handle remaining context in store
			# Empty @NextWords to get all the counts right
			while(@NextWords)
			{
				push(@PreviousWords, $Word) if $Word;
				$Word = shift(@NextWords);
				shift(@PreviousWords);

				# Fill this word/context into the table
				FillContextTable(\%PlainContextTable, $Word, @PreviousWords, @NextWords) if $Word; 
			};
		}	
		else	# Plain text files
		{
			open(TEXTFILE, $FilePath) || die "$FilePath: $!\n";
			while($Sentence = <TEXTFILE>)
			{
		    	# Skip empty lines
		    	next unless $Sentence =~ /[a-z]/i;
		    	next if $Sentence =~ /^\#/;

		    	chomp($Sentence); # Remove EOL
				
		    	# Cut sentence into single words (taking care of 's )
		    	my @WordSentence = SplitIntoWords($Sentence);

		    	# Fill tables
		    	my $i;
		    	for($i=0; $i < scalar(@WordSentence); ++$i)
		    	{
	    			# Skip non-words
	    			next unless $WordSentence[$i] =~ /[a-z]/i;
                    # Skip XML tags
                    next if $WordSentence[$i] =~ /\<[^\>]*\>/;
					my $NextContextWord = lc($WordSentence[$i]);

					next if $NextContextWord =~ /\*[ax]|xxx|ggg/i;
					$NextContextWord =~ s/\*.*$//ig;
	    				push(@NextWords, $NextContextWord);
					push(@PreviousWords, $Word) if $Word;
					$Word = shift(@NextWords) if scalar(@NextWords) > $WindowLength;
					shift(@PreviousWords) if scalar(@PreviousWords) > $WindowLength;

					# Fill this word/context into the table
					FillContextTable(\%PlainContextTable, $Word, @PreviousWords, @NextWords) if $Word; 
		    	};
			};
			# File is processed, now handle remaining context in store
			# Empty @NextWords to get all the counts right
			while(@NextWords)
			{
				push(@PreviousWords, $Word) if $Word;
				$Word = shift(@NextWords);
				shift(@PreviousWords);

				# Fill this word/context into the table
				FillContextTable(\%PlainContextTable, $Word, @PreviousWords, @NextWords) if $Word; 
			};
		};
		
    };
};
# Replace counts by frequencies
ContextTableFrequencies(\%PlainContextTable);
ContextTableFrequencies(\%LemmaContextTable);
# Calculate the Context distinctiveness
ContextTableDistinctiveness(\%PlainContextTable);
ContextTableDistinctiveness(\%LemmaContextTable);

my $WordType;
foreach $ContextTable (\%PlainContextTable, \%LemmaContextTable)
{
	next unless $$ContextTable{'!TOTAL!'}{'!COUNT!'} > 0;
	# Store Database information
	my $Type = $$ContextTable{'!TYPE!'};
	my $CurrentDatabaseFile = "$Type$TableName.txt";
	# Create a database file if it doesn't exist
	unless(-e "$DatabaseFiles$CurrentDatabaseFile")
	{
    	open(DATABASE, ">$DatabaseFiles$CurrentDatabaseFile") 
    	|| die "$DatabaseFiles$CurrentDatabaseFile: $!\n";
    	print DATABASE "\#> ", join("\n\#> ", @ColumnHeaders), "\n# \n# $Type$TableName\n# \n";

    	# Print the copyright license
    	if(open(LICENSE, "<./licenseterms.txt"))
    	{
	    	my $Date = localtime();
	    	$Date =~ /\s([\d]+)\s*$/;
	    	my $Year = $1;
	    	while(<LICENSE>)
	    	{
		    	if(/\©/ && ! /$Year/)
		    	{
			    	s/(\d)\s{6}(\s+\#)/\1, $Year\2/ig;
		    	};
		    	print DATABASE $_;
	    	};
	    	close(LICENSE)
    	};

    	close(DATABASE);
	};


	# Warn about number of counts
	my $NumberOfWordForms = 0;
	my $NumberOfWords = 0;
	my $SumRelFrequency = 0;
	my $OrdinalNumber = 0;
	# Open the correct DatabaseFile and add the current record
	open(DATABASE, ">>$DatabaseFiles$CurrentDatabaseFile") 
    	 || die "$DatabaseFiles$CurrentDatabaseFile: $!\n";
	foreach $Word (sort(keys(%$ContextTable)))
	{
		++$OrdinalNumber;
    	# Skip empty words and NON-words (i.e., things with !)
    	next if $Word !~ /\S/ || $Word =~ /\!/;
    	my $RelFrequency = $$ContextTable{$Word}{'!RELFREQUENCY!'};
    	my $WordInfo = $RelFrequency > 0 ? -log($RelFrequency)/log(2) : 0;
    	my $CurrentRecord = ""
    	."$OrdinalNumber\t"
    	."$Word\t"
    	."$$ContextTable{$Word}{'!COUNT!'}\t"
    	."$$ContextTable{$Word}{'!RELFREQUENCY!'}\t"
    	."$WordInfo\t"
    	."$$ContextTable{$Word}{'!CONTEXTDISTINCTIVENESS!'}\t"
    	.($WordInfo - $$ContextTable{$Word}{'!CONTEXTDISTINCTIVENESS!'})."\t"
    	."\n";

	if($Word ne '!TOTAL!')
	{
		$SumRelFrequency += $$ContextTable{$Word}{'!RELFREQUENCY!'};
		++$NumberOfWordForms;
		$NumberOfWords += $$ContextTable{$Word}{'!COUNT!'};
	};

    	print DATABASE $CurrentRecord;
	};
	close(DATABASE);

	print STDERR "\n\nNumber Of WordForms: $NumberOfWordForms\n";
	print STDERR "NumberOfWords: $NumberOfWords == $$ContextTable{'!TOTAL!'}{'!COUNT!'}\n";
	print STDERR "SumRelFrequency: $SumRelFrequency (should be 1)\n";
};
