#! /usr/bin/perl
#
# Read a Praat label chunk file and split the sound (and label) files into sentences.
#
# Use:
# 
#
###############################################################################
#
# 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/NormalText.pl";
# require "$Scripts/SplitText.pl";

my $SoundFiles        = "$DataPath/chunks/";
my $SoundSentenceFiles = "$DataPath/sentences/";

my $PunctuationChars = '(^|\s)[\,\:\;\`\'\-\"](\s|$)';

my $ADDPAUSE = 1;

# Get an order code for chunks
my %StyleOrder = (
'VI' => 0,
'FPA1' => 30,
'FPA2' => 31,
'FT' => 32,
'FS' => 46,
'FW' => 47,
'FY' => 48,
'FR' => 49,
'FPB1' => 52,
'FPB2' => 53,
'VT' => 55,
'VS' => 90,
'PS' => 92,
'VW' => 94,
'VY' => 96,
'VR' => 98
);

# Give each chunk a unique number
sub chunkNumberCode # ($ChunkID) -> $Number
{
   my $ChunkID = shift || return -1;

   my  $ChunkStyle = "";
   my  $ChunkNumber = -1;

   my $ChunkList = join("|", keys(%StyleOrder));
   if($ChunkID =~ /($ChunkList)/)
   {
       $ChunkStyle = $1;
       $ChunkNumber = $';
       $ChunkNumber = $ChunkNumber =~ /^([\d]+)/ ? $1 : 0;
   }
   else
   {
       return -1;
   };

   my $ChunkCodeNumber = $StyleOrder{$ChunkStyle};

   if(grep(/$ChunkStyle/, ('VI', 'FT', 'VT')))
   {
       $ChunkCodeNumber += $ChunkNumber;
   };

   return $ChunkCodeNumber * 1000;   # Allow ampel room for sentences
}

# A routine to construct element ID codes
sub IncreaseIDcode	#	($IDSTRING) -> $NEW_IDSTRING
{
	my $ID = shift || 'A';
	my $Lowest = shift || (($ID =~ /[A-Z]/i) ? 'A' : '0');
	# ID ends in Alphabetic code
	my $Code = "";
	my $Rest = "";
	# Handle the fixed pronunciations
	my @FixedPronunciationLabels = ('ABC', 'NUM', 'VOW', 'HVDA', 'HVDB',
		'VCVA', 'VCVB', 'VCVC', 'VCVD', 'VCVE', 'VCVF', 'VCVG', 'VCVH');
	if($ID =~ /(FP[AB][12])([A-Z]+)$/)
	{
		my $CurrentFPlabel = $2;
		$ID = $`;
		$Code = $1;
		while(@FixedPronunciationLabels && 
              $CurrentFPlabel ne shift(@FixedPronunciationLabels)){};
		$Code .= shift(@FixedPronunciationLabels);
	}
	elsif($ID =~ /[A-Z\-\.\,]+(\_|$)/i)
	{
		$Code = $&;
		$ID = $`;
		$Rest = $';

		if($Code =~ /([A-Z]+)([\.,]*)$/)
		{
			my $Increase = $1;
			++$Increase;
			$Increase =~ s/A/$Lowest/g if $Lowest ne 'A';
			$Code = "$`$Increase$2";
		};
	}
	# ID ends in Numerical code
	elsif($ID =~ /[\d\-\.\,]+(\_|$)/i)
	{
		$Code = $&;
		$ID = $`;
		$Rest = $';
		if($Code =~ /([\d]+)([\.,]*)$/)
		{
			my $Increase = $1;
			++$Increase;
			$Increase =~ s/\0/$Lowest/g if $Lowest ne '0';
			$Code = "$`$Increase$2";
		};
	};
	$ID .= $Code;
	$ID .= "_$Rest" if $Rest;

	return $ID;
};

#
# Fill in missing ID numbers with UNIQUE codes
sub InterpolateIDtier	# (\@Tier) -> \@Tier;
{
	my $Tier = shift || return 0;

	#
	my $i = 0;
	for($i=0; $i<scalar(@$Tier); ++$i)
	{
		my $IDcode = $$Tier[$i];
		unless($IDcode)
		{
			my $PreviousIDcode = $i > 0 ? $$Tier[$i-1] : "";
			my $NextIDcode = "";
			my $j;
			for($j=$i+1; $j < scalar(@$Tier) && !$NextIDcode; ++$j)
			{
				$NextIDcode = $$Tier[$j];
			};

			my $NewIDcode = $PreviousIDcode;
			# Simple just add -A or -1
			if($PreviousIDcode !~ /\-(\d+|[a-z]+)$/i)
			{
				if($NextIDcode !~ /$PreviousIDcode\-(\d+|[a-z]+)$/i)
				{
					$NewIDcode .= $PreviousIDcode =~ /\d+$/ ? '-1' : '-A';
				}
				else
				{
					$NewIDcode .= $PreviousIDcode =~ /\d+$/ ? '--1' : '--A';
				};

				# Make sure the ID is unique
				while(grep(/$NewIDcode/, @$Tier))
				{
					$NewIDcode = IncreaseIDcode($NewIDcode);
				};
			}
			# A little less simple
			elsif($PreviousIDcode =~ /\-([\d]+|[a-z]+)\-([\d]+|[a-z]+)$/i)
			{
				$NewIDcode = $`."-";
				my $Insert1 = $1;
				# Make sure the ID is unique
				while(grep(/$NewIDcode$Insert1/, @$Tier))
				{
					++$Insert1;
				};
				my $Insert2 = $Insert1 =~ /\d+$/ ? '1' : 'A';
				$NewIDcode .= "$Insert1-$Insert2";
			}
			# Almost simple
			elsif($PreviousIDcode =~ /[\-]+([\d]+|[a-z]+)$/i)
			{
				$NewIDcode = $`."-";
				my $Insert1 = $1;
				$Insert1 = $Insert1 =~ /\d+$/ ? '2' : 'B';
				# Make sure the ID is unique
				while(grep(/$NewIDcode$Insert1/, @$Tier))
				{
					++$Insert1;
				};
				my $Insert2 = $Insert1 =~ /\d+$/ ? '1' : 'A';
				$NewIDcode .= "$Insert1-$Insert2";
			};

			$$Tier[$i] = $NewIDcode;
		};
	};
	return $Tier;
};

#
# A list of readable names
my %RealNames =
(
'F' => 'Fixed',
'V' => 'Variable',
'PS' => 'PseudoSent',
'I' => 'Informal',
'R' => 'Retold',
'T' => 'Read',
'S' => 'Sentence',
'W' => 'Word',
'Y' => 'Syllable',
'PR' => 'Pronunciation'
);

# Read label files
sub split_label_file      # ($ID, $FileID, $FORMAT, <DATABASE>)
{
    my $ID = shift || die "No speaker ID\n";
    my $FileID = shift || die "No file ID\n";
    my $FORMAT = shift || "";
    my $Database = shift || "";


    my $ChunkFileName = "$ID/$ID$FileID.aifc";
    my @MasterPraatScript = ();

    my $SpeakerID = $ID;
    $ID =~ /([FM])(\d+)([A-Z])/i;
    my $SpeakerSex = $1;
    my $SpeakerAge = $2;

    print "ERROR: $FileID\n" unless $FileID =~ /^([\d]+)([FVP])([A-Z]+)/i;
    my $RecordingNo = $1;
    my $TextType = $2;
    my $Style = $3;
    # Handle exceptions
    if("$TextType$Style" eq 'PS')
    {
	    $TextType = 'F';
	    $Style = 'PS';
    };
    # Handle exceptions
    if("$TextType$Style" =~ 'FP[AB]')
    {
	    $TextType = 'F';
	    $Style = 'PR';
    };

    # Get the author
    my $Author = '-';   # Default is maintainer (that is ME)
    if($FileID =~ /\_(.+)$/i)
    {
	$Author = $1;
    };

    # Make types readable
    $TextStyle = $RealNames{$TextType} ? $RealNames{$TextType} : $TextType;
    $TextStyle .= $RealNames{$Style} ? $RealNames{$Style} : $Style;

    # open source label file
    open(SOURCE, "<$ChunkLabels/$ID/$ID$FileID.translit") || die "$ChunkLabels/$ID/$LabelType/$ID$FileID.translit: $!\n";

    #
    # Define all Tiers
    my @AllTiers = (SENTENCE, TRANSLIT);
    my $IDformat = "IDFOLDED";

    my $Tier;
    foreach $Tier (@AllTiers)
    {
	    ${$Tier} = $IDformat;
	    @{$Tier.'tier'} = ();
	    @{$Tier.'IDtier'} = ();
	    @{$Tier.'start'} = ();
	    @{$Tier.'end'} = ();
    };
    #

    #
    # Fill all the TIERS
    #
    # From a TextGrid (label)
    my %TierFromGrid = ();    # Record whether Tier has been read from grid!
    my $Line;
    my $SentenceIDcode = 'A';
    #
    # Read in the complete source file
    @AllLines = <SOURCE>;
    if(@AllLines)
    {
	    my $Tier = "";
	    while($Line = shift(@AllLines) || @AllLines)
	    {
		    # A Tier has been found
		    if($Line =~ /\"IntervalTier\"/i)
		    {
			    # Get the Tier name
			    $Line = shift(@AllLines);
			    if($Line =~ /\"(\w+)\"/i)
			    {
				    $Tier = $1;
				    # Check whether the tier name is correct
				    my $TierName = $Tier;
				    $TierName =~ s/ID$//g;
				    next unless grep(/^\Q$TierName\E$/, @AllTiers);
				    # Mark tier as read
				    ++$TierFromGrid{$TierName};

				    #
				    my $StartTime = shift(@AllLines);
				    my $EndTime = shift(@AllLines);
				    $DURATION = $EndTime - $StartTime;
				    my $NumberOfItems = shift(@AllLines);
				    #
				    my ($TierPtr, $IDtierPtr, $TierStartPtr, $TierEndPtr);
				    eval('$TierPtr = \@'.$Tier.'tier;'); 
				    eval('$IDtierPtr = \@'.$Tier.'IDtier;'); 
				    eval('$TierStartPtr = \@'.$Tier.'start;'); 
				    eval('$TierEndPtr = \@'.$Tier.'end;');

				    # Read all the items 
				    my $OldIDcode = "";
				    while(@AllLines && ($AllLines[0] !~ /\"IntervalTier\"/))
				    {
					    # Start
					    $Line = shift(@AllLines);
					    next unless $Line =~ /\S/;
					    $Line =~ /[\d\.]+/;
					    push(@$TierStartPtr, $&);
					    # End
					    $Line = shift(@AllLines);
					    $Line =~ /[\d\.]+/;
					    push(@$TierEndPtr, $&);
					    # Label
					    $Line = shift(@AllLines);
					    $Line =~ s/[\s]+/ /g;   # Remove all whitespace 
					    $Line =~ s/^\s*\"//g;   # Remove leading spaces
					    $Line =~ s/\"\s*$//g;   # Remove trailing spaces
					    $Line =~ s/\'\'/\'/g;   # Prevent '-quote doubling
					    $Line =~ s/\"\"/\"/g;   # Prevent "-quote doubling
    print STDERR "BAD LABEL: '$Line', '$TierName' '$ID$FileID'\n" if $Line && $Line !~ /[a-z]/i;

					    # Extract Folded ID codes
					    # Marked by a double _
					    if($Line =~ /[\_]{2}/)
					    {
					    	    my $FoldedIDcode = $';
						    $Line = $`;
						    $FoldedIDcode =~ s/\s//g;
						    push(@$IDtierPtr, $FoldedIDcode);
					    }
					    elsif(@$IDtierPtr)
					    {
						    push(@$IDtierPtr, "");
					    };
					    # Store the actual value
					    push(@$TierPtr, $Line);

				    };
				    # Every label should have an ID
				    InterpolateIDtier($IDtierPtr);
			    };
		    };
	    };
    };

    #
    # Make formatted Table output
    #
    # Get the names of the requested tiers
    my @PrintedTiers = grep(/\S/, map {scalar(@{$_."tier"}) ? $_ : "";} @AllTiers);
    my $i;

    my $SentenceNumber = chunkNumberCode($FileID);   # Get a Chunk order code number (*1000)
    # Extract all non-empty labels
    for($i=0; $i < scalar(@TRANSLITtier); ++$i)
    {
	    # If the label is NOT empty
	    if($TRANSLITtier[$i]=~ /[\w]/)
	    {
		    my $IDcode = $TRANSLITIDtier[$i];
		    # Do not overwrite existing labelfiles
    print STDERR "IDCODE: $i '$IDcode' '$TRANSLITtier[$i]' $TRANSLITIDtier[$i-1] $TRANSLITIDtier[$i+1]\n" unless $IDcode;

		    # Get boundaries of current label
		    my $StartTime = $TRANSLITstart[$i];
		    my $EndTime = $TRANSLITend[$i];

		    #################################################################################################
		    #
		    # Write database output
		    #
		    #################################################################################################
		    ++$SentenceNumber;
		    my $CurrStyle = $Style;

		    my $TierLength = scalar(@TRANSLITtier);

		    # Determine previous and next non-pauze ID's
		    my $PreviousItem = $i-1;
		    while($PreviousItem >= 0 && $TRANSLITtier[$PreviousItem] !~ /\w/){ --$PreviousItem;};
		    my $PreviousID = $PreviousItem < 0 ? '*' : $TRANSLITIDtier[$PreviousItem];

		    my $NextItem = $i+1;
		    while($NextItem < $TierLength && $TRANSLITtier[$NextItem] !~ /\w/){ ++$NextItem;};
		    my $NextID = $NextItem >= $TierLength ? '*' : $TRANSLITIDtier[$NextItem];

		    # Print to database
		    print $Database "$TRANSLITIDtier[$i]\t";				# The ID of the sentence
		    print $Database "$SpeakerID\t";					# Speaker
		    print $Database "$SpeakerSex\t";					# Sex
		    print $Database "$SpeakerAge\t";					# Age
		    print $Database "$TextType\t";					# TextType
		    print $Database "$Style\t";						# Speaking style
		    print $Database "$TextStyle\t";					# Collpoquial names of Type and style		    
		    print $Database "$RecordingNo\t";					# Recording number	
		    print $Database "$Author\t";					# author
		    print $Database "$i\t";						# Item number
		    print $Database $SentenceNumber%1000, "\t";				# Sentence number
		    print $Database "$SentenceNumber\t";				# Global Sentence Order number
		    print $Database "*\t";						# Status: * = Raw, Unsegmented
		    print $Database ($i > 0 ? "$TRANSLITIDtier[$i-1]\t" : "*\t");	# The ID of the previous item
		    print $Database ($i+1 < $TierLength ? "$TRANSLITIDtier[$i+1]\t" : "*\t");	# The ID of the next item
		    print $Database "$PreviousID\t";					# The ID of the previous sentence
		    print $Database "$NextID\t";					# The ID of the next sentence
		    print $Database "$ID$FileID\t";					# Parent ID
		    print $Database "$StartTime\t";					# Aproximate start-time
		    print $Database "$EndTime\t";					# Aproximate end-time
		    print $Database $EndTime-$StartTime, "\t";				# Aproximate duration
		    print $Database scalar(grep(/\w/, split(' ', $TRANSLITtier[$i]))), "\t";	# Aproximate number of words
		    # Clean up text
		    $TRANSLITtier[$i] =~ s/[\'\"]/\`/g;
		    
		    print $Database "'$TRANSLITtier[$i]'\n";					# The sentence

		    #
		    #################################################################################################
		};
	};
};

@ARGV =  map {m@[^/]+$@; $&;} glob("$HomeDir/Labels/sentences/[FM]*") unless @ARGV; 
my $ID;
while($ID = shift(@ARGV))
{
	my @SpeakerList = grep(!/CVS/, glob("$ChunkLabels/$ID"));
	my $Speaker;
	
	foreach $Speaker (@SpeakerList)
	{
		$Speaker =~ m@[^/]+$@;
		$Speaker = $&;
		open(DATABASE, ">$DatabaseTables/${Speaker}Sentences.txt") 
		|| die "Database >$DatabaseTables/${Speaker}Sentences.txt: $!\n";
		print DATABASE << "HEADEREND";
\#> ID [TEXT] IDcode of sentence
\#> Speaker [TEXT] Speaker ID
\#> Sex [CHAR(1)] Speaker sex
\#> Age [INT2] Speaker age
\#> TextType [CHAR(1)] Type of text (Fixed/Variable)
\#> Style [CHAR(4)] Speaking style
\#> StyleName [TEXT] Colloqial name of style and type
\#> RecNo [INT2] Number of recording session
\#> Author [TEXT] ID of annotator
\#> ItemNo [INT4] Number of item in chunk
\#> SentNo [INT4] Number of sentence for this style
\#> OrderNo [INT4] Unique Order number for sorting sentences
\#> Status [CHAR(2)] Segmentation/labeling status
\#> PrevID [TEXT] IDcode of previous item
\#> NextID [TEXT] IDcode of next item
\#> PrevSent [TEXT] IDcode of previous non-empty sentence
\#> NextSent [TEXT] IDcode of next non-empty sentence
\#> ParentID [TEXT] IDcode of parent chunk
\#> StartTime [FLOAT] Start time of sentence in file
\#> EndTime [FLOAT] End time of sentence in file
\#> Duration [FLOAT] Duration of sentence
\#> NumbWords [INT2] Number of words in sentence
\#> Translit [TEXT] Transliteration of speech
\#
\# Sentence and Translit
\#
HEADEREND
		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)
		};

	# Chunks
	my @MasterPraatScript = ();
	foreach $FileType ('1FS', '2VS', '2PS', '1FW', '2VW', '1FY', '2VY', '1FPA1', '1FPA2', '2FPB1', '2FPB2')
	{
		if(-e "$ChunkLabels/$Speaker/$Speaker$FileType.translit")
		{
  			my $FileID = "${FileType}";
  			my $FORMAT = "";

			split_label_file($Speaker, $FileID, $FORMAT, DATABASE);
		};
	};

	# Chunks
	foreach $FileType ('1VI', '1FT', '1FR', '2VT', '2VR')
	{
		my $Chunk = 1;
		while(-e "$ChunkLabels/$Speaker/$Speaker$FileType$Chunk.translit")
		{
  			my $FileID = "${FileType}$Chunk";
  			my $FORMAT = "";

  			split_label_file($Speaker, $FileID, $FORMAT, DATABASE);

			++$Chunk;
		};
	};

	close(DATABASE) || die "Database >$DatabaseTables/${Speaker}Sentences.txt: $!\n";
    };
};

exit;

