#! /usr/bin/perl
#
# Special purpose program for Unix/Linux:
# Read all arguments as aligned praat prephoneme label files with 
# translit, words, and syllables tiers.
#
# Construct a Database table for each tier.
#
# Use:
# ./ConstructPhonemeTables.pl <SpeakerGlob>
#
# This will read in all files from <SpeakerGlob> (e.g., F*)
# and constructs Table files with the names <Speaker><tier>.txt
# in the phoneme/<tier> subdirectories of the DatabaseFiles/ directory
#
#
###############################################################################
#
# 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/CGN_phonemes.pl";  # For the phoneme classes
require "$Scripts/SentenceLabel.pl";

#
# Where are the files
my $TypeExtension = 'prephoneme';
my $TableDirectory = "$DatabaseTables/$TypeExtension";

#
# Tiers to handle
@TierList = ('PHONEMES', 'SYLLPARTS', 'SYLLABLES', 'WORDS', 'TRANSLIT');

# Postediting routines for all tiers
# Given a Sentence Label and a Record list, they will change/add the
# values in the Record.
# The Column Headers list will add the corresponding column headers.
my @PHONEMEScolumnHeaders = (
'Manner [CHAR(1)]', 'Articulator [CHAR(1)]', 'Voicing [CHAR(1)]',
'prevManner [CHAR(1)]', 'prevArticulator [CHAR(1)]', 'prevVoicing [CHAR(1)]',
'nextManner [CHAR(1)]', 'nextArticulator [CHAR(1)]', 'nextVoicing [CHAR(1)]'
);
sub PHONEMESedit	# ($Label, \@Records)
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;
    
    # Phoneme information of current, previous and next Phoneme
    my $i;
    foreach $i (5, 13, 15)
    {
	# Get Manner, Articulator and Voicing
	my $Manner = $CGN_phonemes{$Record->[$i]}[0];
	my $Articulator = $CGN_phonemes{$Record->[$i]}[1];
	my $Voicing = $CGN_phonemes{$Record->[$i]}[2];
	
	push(@$Record, $Manner, $Articulator, $Voicing);
    };
    
    return @$Record;
}

my @SYLLPARTScolumnHeaders = ('NumPhon [INT2]');
sub SYLLPARTSedit	# ($Label, \@Records)  
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;
    
    my $Value = $Record->[5];
    $Value =~ s/[\+\-\~\:]//g;
    push(@$Record, length($Value));
    
    return 1;
}

my @SYLLABLEScolumnHeaders = ('Stress [CHAR(1)]', 'prevStress [CHAR(1)]', 'nextStress [CHAR(1)]', 'NumPhon [INT1]');
sub SYLLABLESedit	# ($Label, \@Record)  
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;
    
    # The syllable stress marker
    my $StressedSyllable = ($Record->[5] =~ s/\"//g) ? '+' : '-';
    my $prevStressedSyllable = ($Record->[13] =~ s/\"//g) ? '+' : '-';
    my $nextStressedSyllable = ($Record->[15] =~ s/\"//g) ? '+' : '-';
    
    push(@$Record, $StressedSyllable, $prevStressedSyllable, $nextStressedSyllable);
    
    my $Value = $Record->[5];
    $Value =~ s/[\+\-\~\:]//g;
    push(@$Record, length($Value));

    return 1;
}

my @CGNcolumnHeaders = ('NumSyll [INT2]', 'StressPatt [TEXT]', 'NumPhon [INT2]');
sub CGNedit	# ($Label, \@Records)  
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;
    
    my $Value = $Record->[5];
    # Get the number of Syllables and the stress pattern
    my @Syllables = map {/\"/ ? 1 : 0;} split(/[\-\_]/, $Value);
    push(@$Record, scalar(@Syllables), join("", @Syllables));
    # Get the number of phonemes
    $Value =~ s/[\+\-\~\:]//g;
    push(@$Record, length($Value));

    return 1;
}

my @WORDScolumnHeaders = ('Marker [CHAR(1)]');
sub WORDSedit	# ($Label, \@Records)  
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;

    # Split of transcription markers like *a, *u, *v, and *x
    my $Value = $Record->[5];
    my ($Word, $Marker) = ($Value, 'NULL');
    if($Word =~ /\*(\S)/)
    {
    	$Marker = uc($1);
	$Word = $`;
    };
    $Record->[5] = $Word;
    
    push(@$Record, $Marker);
    
    # Remove markers from other words
    $Record->[13] =~ s/\*[\w]+//g;
    $Record->[15] =~ s/\*[\w]+//g;
    
    return 1;
}

my @TRANSLITcolumnHeaders = ('NrWords [INT2]', 'NrSyllables [INT2]', 'NrPhonemes [INT2]');
sub TRANSLITedit	# ($Label, \@Records) 
{
    my $Label = shift || return 0;
    my $Record = shift || return 0;
    
    # The word tier
    my $WordTier = 'WORDS';
    
    # Remove unwanted items
    splice(@$Record, 12, 4);

    # Initialize
    my ($WordNumber, $SyllableNumber, $PhonemeNumber) = (0, 0, 0);
    
    # Get the mean words, syllables and phonemes per second from CGN
    # First, count the non-pause words etc. and sum their durations
    $Label->presetItem($WordTier);
    while($Label->nextStartininterval($WordTier, 'TRANSLIT') > -1)
    {
	my $Word = $Label->currentValue($WordTier);
	
	# Skip (filled) pauses (Silence, uh, uhm, enne)
	next if $Word =~ /^(\*|\#|uh|enne|uhm|hm)$/;
	
	# Count words
	++$WordNumber;
    };
    
    # Get the mean words, syllables and phonemes per second from CGN
    # First, count the non-pause words etc. and sum their durations
    my $WordTier = 'SYLLABLES';
    $Label->presetItem($WordTier);
    while($Label->nextStartininterval($WordTier, 'TRANSLIT') > -1)
    {
	my $Word = $Label->currentValue($WordTier);
	
	# Skip (filled) pauses (Silence, uh)
	next if $Word =~ /^(\*|\@)$/;
	
	# Get Syllables
	my $Phonemes = $Word;
	# Remove all superfluous chars
	$Phonemes =~ s/[\"\'\-\:\~\+]//g;
	
	# Count words, syllables and phonemes
	++$SyllableNumber;
	$PhonemeNumber += length($Phonemes);
    };
    
   # Add numbers
    push(@$Record, $WordNumber, $SyllableNumber, $PhonemeNumber);
    
    return 1;
}


my %PostEditors = (
'PHONEMES' => \&PHONEMESedit, 
'SYLLPARTS' => \&SYLLPARTSedit, 
'SYLLABLES' => \&SYLLABLESedit, 
'CGN' => \&CGNedit, 
'WORDS' => \&WORDSedit, 
'TRANSLIT' => \&TRANSLITedit
);

my %PostHeader = (
'PHONEMES' => \@PHONEMEScolumnHeaders, 
'SYLLPARTS' => \@SYLLPARTScolumnHeaders, 
'SYLLABLES' => \@SYLLABLEScolumnHeaders, 
'CGN' => \@CGNcolumnHeaders, 
'WORDS' => \@WORDScolumnHeaders, 
'TRANSLIT' => \@TRANSLITcolumnHeaders
);


# Which phonemes glue to syllparts
sub SyllPartsGlue	# ($CurrentItem, $NextItem) -> 0 (Don't combine), 1 (Combine)
{
	my $CurrentItem = shift || return 0;
	my $NextItem = shift || return 0;
	
	#
	# Vowels and Pauses don't stick
	return 0 if $CGN_phonemes{$CurrentItem}[0] eq 'V' 
	            || $CGN_phonemes{$NextItem}[0] eq 'V';
	# Other is pauses
	return 0 if $CurrentItem eq '*' 
	            || $NextItem eq '*';
		    
	# Consonants just stick
	return 1;
}

#
# Major loop, process all speakers
my $SpeakerGlob;

foreach $SpeakerGlob (@ARGV)
{
    # Get the label filenames
    @PhonemeFileList = 
    glob("$SentenceLabels/$SpeakerGlob/$TypeExtension/*.$TypeExtension");
    # Process all files
    my $File;
    foreach $File (@PhonemeFileList)
    {
	# Get the ID of the current speaker
	my $TranslitFile = "";
	my $CurrentSpeaker = "";
	if($File =~ m@/([^/]+)/$TypeExtension/([^/]+)$@)
	{
	    $CurrentSpeaker = $1;
	    my $CurrentFileName = $2;
	    $CurrentFileName =~ /\.$TypeExtension$/;
	    $CurrentFileName = $`;
	    $TranslitFile = "$SentenceLabels/$CurrentSpeaker/translit/$CurrentFileName.translit";
	}
	else
	{
	    die "No speaker found: $File\n";
	};
	
	# Get the ID of the current author
	my $CurrentAuthor = 'NULL';
	if($File =~ /\_([^\.]+)\.[^\.]+$/)
	{
	    $CurrentAuthor = $1;
	};
	
	my $Label = new SentenceLabel;
	$Label->FoldedIDcodes('TRANSLIT', 'WORDS', 'SYLLABLES', 'PHONEMES');
	
	# Note, in this case the ORDER in which the file are read is important
	next unless $Label->ReadLabelFile($File);
	next unless $Label->ReadLabelFile($TranslitFile);
	
	# Prepare the label for processing (e.g., add ID codes)
	# Remove some "ancient" incorrect phoneme labels
	$Label->map('PHONEMES', '$_ =~ s/\://ig');
	# Interpolate ID codes
	$Label->InterpolateIDtier('WORDS');
	# Make Syllable Parts
	$Label->interpolateBetweenTiers('SYLLPARTS', 
	                       'PHONEMES', 'SYLLABLES', \&SyllPartsGlue);
	# Reorder the Tiers (to fit SYLLPARTS between PHONEMES and SYLLABLES)
	my $LastTier = pop(@{$Label->{'TIERORDER'}});
	splice(@{$Label->{'TIERORDER'}}, 1, 0, $LastTier);

	# Construct the ID codes
	$Label->FillIDcodes;	
	
	$Label->presetItem('TRANSLIT');
	while($Label->nextItem('TRANSLIT') > -1)
	{
	     # Skip empty sentences
	     next unless $Label->currentValue('TRANSLIT') =~ /[^\#\*\s]/;

	     # Correct some odd errors (SentenceID =! TranslitID)
	     $Label->currentItem('SENTENCE', $Label->currentItem('TRANSLIT'));
	     $Label->currentIDcode('SENTENCE', $Label->currentIDcode('TRANSLIT'));
	     
	     my $Tier;
	     foreach $Tier (@TierList)
	     {
		     my @Table = $Label->TierToTable($Tier, 'TRANSLIT', $PostEditors{$Tier}, $CurrentAuthor);
        	     print STDERR "Error with '$Tier' from $File\n" unless @Table;

		     # Print result to file
		     my $PrintHeader = (-e "$TableDirectory/$CurrentSpeaker$Tier$TypeExtension.txt") ? 0 : 1;
		     open(OUTPUT, ">>$TableDirectory/$CurrentSpeaker$Tier$TypeExtension.txt") 
		     || die ">>$TableDirectory/$CurrentSpeaker$Tier$TypeExtension.txt: $!\n";

		     # Print the column headers
		     if($PrintHeader)
		     {
		             # Make sure the tier is somewhere
		     	     $Label->currentItem($Tier, 1) unless $Tier eq 'TRANSLIT';
			     
			     # Construct the list with column headers
			     my @CurrentHeaders = $Label->TierToTableColumnheaders($Tier, @{$PostHeader{$Tier}}, 'Author [TEXT]');
			     # Remove some items if using the TRANSLIT tier
			     splice(@CurrentHeaders, 12, 4) if $Tier eq 'TRANSLIT';
			     
		     	     # NO times
			     splice(@CurrentHeaders, 6, 6);
			     
			     # Print the column headers
			     print OUTPUT "\# ", join("\t", @CurrentHeaders), "\n";

			     # Print some extra information
			     print OUTPUT "\# ";
			     print OUTPUT "Tier: $Tier\n\# Speaker: $CurrentSpeaker\n\# Source: $TypeExtension\n";
			     print OUTPUT "\#\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 OUTPUT $_;
				     };
				     close(LICENSE)
			     };

			     
			     # Header is printed ONLY once
			     $PrintHeader = 0;
		     };

		     my $Record;
		     foreach $Record (@Table)
		     {
		     	     # NO times
			     splice(@$Record, 6, 6);

			     print OUTPUT join("\t", @$Record), "\n";
		     };
		     close(OUTPUT);
	     };
	};
    };
    
};



