#! /usr/bin/perl
#
# Read a Praat label sentence file and split the Transliteration tier into words, 
# syllables, and phonemes.
#
#    Copyright (C) 2000, 2001  R.J.J.H. van Son
# 
#    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
#
use SDBM_File;
use POSIX;
push(@INC, '/home/rob/OSS/GTPhconv');
$DBMconnect = require 'GTPhconvdbm.pl' || die "'GTPhconvdbm.pl' $!\n";
require "NormalText.pl";
require "SplitText.pl";
require "TranscribeCGN.pl";

my $CorpusHome = "/u/rob/SLcorpus";

my $SentenceLabels    = "$CorpusHome/Labels/sentences/";
my $PhonemeLabels    = "$CorpusHome/Labels/sentences/";

my $DatabaseFiles = "$CorpusHome/DatabaseFiles/";

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

my $ADDWORDPAUSE = 1;

my $FilesWritten = 0;

#
#####################################################################################
#
#       Transcription tables
#
#####################################################################################
#
# Just a list of fixed "words"
my %FixedPronunciation = (
'#'  => '*',
"oe" => 'u',
"oo" => 'o',
"o"  => 'O',
"a"  => 'A',
"aa" => 'a',
"e"  => 'E',
"ee" => 'e',
"i"  => 'I',
"ie" => 'i',
"uu" => 'y',
"u"  => 'Y',
"eu" => '2',
"ei" => 'E+',
"au" => 'O+',
"ui" => '9+',
"hied" => 'hit',
"hid"  => 'hIt',
"heed" => 'het',
"hed"  => 'hEt',
"huud" => 'hyt',
"hud"  => 'hYt',
"heud" => 'h2t',
"hoed" => 'hut',
"hood" => 'hot',
"hod"  => 'hOt',
"had"  => 'hAt',
"haad"  => 'hAt',
"heid" => 'hE+t',
"houd" => 'hO+t',
"huid" => 'h9+t',
"nee" => 'ne',
"k"  => 'k',
"ng" => 'N',
"t"  => 't',
"n"  => 'n',
"p"  => 'p',
"m"  => 'm',
"d"  => 'd',
"l"  => 'l',
"b"  => 'b',
"r"  => 'r',
"g"  => 'x',
"h"  => 'h',
"s"  => 's',
"w"  => 'w',
"f"  => 'f',
"j"  => 'j',
"z"  => 'z',
"sj" => 'S',
"v"  => 'v',
"nj" => 'J'
);

# Get orthographic "phonemes"
my %SyllableTranslit = (
'#'  => '*',
"oe" => 'u',
"oo" => 'o',
"o"  => 'O',
"a"  => 'A',
"aa" => 'a',
"e"  => 'E',
"ee" => 'e',
"i"  => 'I',
"ie" => 'i',
"uu" => 'y',
"u"  => 'Y',
"eu" =>  '2',
"ei" => 'E+',
"ij" => 'E+',
"au" => 'O+',
"ui" => '9+',
"oh"  => 'O',
"ah"  => 'A',
"eh"  => 'E',
"ih"  => 'I',
"uh"  => 'Y',
"ch"  => 'x',
"k"  => 'k',
"ng" => 'N',
"n-g" => 'n-x',
"t"  => 't',
"n"  => 'n',
"p"  => 'p',
"m"  => 'm',
"d"  => 'd',
"l"  => 'l',
"b"  => 'b',
"r"  => 'r',
"g"  => 'x',
"h"  => 'h',
"s"  => 's',
"w"  => 'w',
"f"  => 'f',
"j"  => 'j',
"z"  => 'z',
"sj" => 'S',
"zj" => 'Z',
"v"  => 'v',
"nj" => 'J',
"n-j" => 'n-j',
"abbah" => 'A-bA',
"aabaa" => 'a-ba',
"appah" => 'A-pA',
"aapaa" => 'a-pa',
"addah" => 'A-dA',
"aadaa" => 'a-da',
"attah" => 'A-tA',
"aataa" => 'a-ta'
);

# Make sure the target directory exists
sub create_Labeldirectory  # ($ID, $LabelType) -> 1/0 create directory if necessary
{
    my $ID = shift || return 0;
    my $LabelType = shift || return 0;
    #
    my $DirExists = -d "$SentenceLabels$ID/$LabelType";
    (return mkdir("$SentenceLabels$ID/$LabelType", 0744) || die "$SentenceLabels$ID/$LabelType: $!\n") unless $DirExists;
    return 0;   # Nothing done
}

# 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;
};

#
# Split a line of text into words
my $PunctuationChars = '(^|\s)[\,\:\;\`\'\-](\s|$)';
sub SplitIntoWords      # ($line, $NoDoubleWords) -> @LineOfWords;
{
    my $Line = shift || " ";
    my $NoDoubleWords = shift || 0;
    
    my @LineOfWords = (" ");
    my @AllWords = ();
    
    # Empty line contains a single space
    return @LineOfWords unless $Line =~ /\S/;
    
    # Split line to words
    $Line =~ s/([\'\`]s)\s+(morg|ocht|mid|avond|nacht|here|graven|hert)/\1\-\2/g;
    @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));
        }
        elsif(!$NoDoubleWords && ::LookUpCGN("$LineOfWords[0] $LineOfWords[1]"))
        {
            push(@AllWords, "$LineOfWords[0] $LineOfWords[1]");
            shift(@LineOfWords);
            shift(@LineOfWords);
        }
        else
        {
            push(@AllWords, $LineOfWords[0]);
            shift(@LineOfWords);
        };
    };
    
    return @AllWords;
};

#
# 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;
};

# Read label files
sub transcribe_translit_file      # ($ID, $FileID)
{
    my $ID = shift || die "No speaker ID\n";
    my $FileID = shift || die "No file ID\n";
    
    # Create target directory if necessary
    my $LabelType = "phoneme";
    create_Labeldirectory($ID, $LabelType);
    $LabelType = "prephoneme";
    create_Labeldirectory($ID, $LabelType);
    
    # Store unknown words
    my %UnknownWords = ();
    
    # Don't change existing file
    return 0 if (-e "$SentenceLabels$ID/$LabelType/$FileID.$LabelType");
    # open source label file
    open(SOURCE, "<$SentenceLabels$ID/translit/$FileID.translit") || die "$SentenceLabels$ID/translit/$FileID.translit: $!\n";
    
    #
    # Work in CGN format (NOT SAMPA)
    $::use_CGN = 1;
    
    my %Sonority =
    (
    'p' => '1',
    'b' => '2',
    't' => '1',
    'd' => '2',
    'k' => '1',
    'g' => '2',
    'f' => '3',
    'v' => '4',
    's' => '3',
    'z' => '4',
    'S' => '3',
    'Z' => '4',
    'x' => '3',
    'G' => '4',
    'h' => '1',
    'N' => '5',
    'm' => '5',
    'n' => '5',
    'J' => '6',
    'l' => '6',
    'r' => '6',
    'w' => '7',
    'j' => '7',
    'I' => '8',
    'E' => '8',
    'A' => '8',
    'O' => '8',
    'Y' => '7',
    'i' => '7',
    'y' => '7',
    'e' => '8',
    '2' => '8',
    'a' => '9',
    'o' => '8',
    'u' => '7',
    '@' => '6',
    'E+' => '8',
    '9+' => '8',
    'O+' => '8',
    'E:' => '8',
    '9:' => '7',
    'O:' => '8',
    'E~' => '8',
    'A~' => '8',
    'O~' => '8',
    'Y~' => '7'
    );
    
    #
    # Define all Tiers
    my @AllTiers = (SENTENCE, TRANSLIT, WORDS, CGN, SYLLABLES, SYLLPARTS, PHONEMES);
    my $IDformat = "";
    
    my $Tier;
    foreach $Tier (@AllTiers)
    {
        ${$Tier} = $IDformat;
        @{$Tier.'tier'} = ();
        @{$Tier.'IDtier'} = ();
        @{$Tier.'start'} = ();
        @{$Tier.'end'} = ();
    };
    $WORDS = 'IDFOLDED';
    #
    
    #
    # 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*\"\s+\"\s*$/\"#__\"/g;  # Insert Silence 
                        $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
                        $Line =~ s/[\"]+/\"/g;   # Prevent "-quote doubling
                        
                        # Extract Folded ID codes
                        # Marked by a double _
                        if($Line =~ /[\_]{2}/)
                        {
                            push(@$IDtierPtr, $');
                            $Line = $`;
                        }
                        elsif(@$IDtierPtr)
                        {
                            push(@$IDtierPtr, "");
                        };
                        # Store the actual value
                        push(@$TierPtr, $Line);
                        
                    };
                    # Every label should have an ID
                    InterpolateIDtier($IDtierPtr);
                };
            };
        };
    };
    
    # Fill All Remaining tiers
    #
    # Fill the Words Tier from the Transliterated Tier.
    #
    # Do not split isolated word texts into double words
    my $NoDoubleWords = ($FileID =~ /${ID}[\d]+([FV][WY]|FP[AB])[\d+]/) ? 1 : 1; # Actually, use NO double words
    unless(@WORDStier)
    {
        for($Line=0; $Line < scalar(@TRANSLITtier); ++$Line)
        {
            # Get sentence values
            my $Text = lc($TRANSLITtier[$Line]);
            my $SentenceIDcode = $TRANSLITIDtier[$Line];
            my $SentenceStart = $TRANSLITstart[$Line];
            my $SentenceEnd = $TRANSLITend[$Line];
            # Initialize ID code
            my $WordIDcode = $SentenceIDcode."1";
            # 
            # Split Text into Words
            my @AllWords = grep(!/[\.\?\!](\s|$)/, SplitIntoWords($Text, $NoDoubleWords));
            @AllWords = ("#") unless @AllWords;
            # Determine word length
            my $DeltaT = ($SentenceEnd - $SentenceStart);
            $DeltaT /= scalar(@AllWords) if @AllWords;
            $DeltaT = ($SentenceEnd - $SentenceStart)/(2*scalar(@AllWords) - 1) if $ADDWORDPAUSE;
            my $Word;
            my $LineCount = 0;
            my $TotalLineCount = scalar(@AllWords);
            my $CorrectionQuotient = $DeltaT > 0 ? ($SentenceEnd - $SentenceStart)/$DeltaT - 1 : 1;
            # Store words in Words Tier
            foreach $Word (@AllWords)
            {
                $Word = '#' unless $Word =~ /\S/;
                push(@WORDStier, $Word);
                push(@WORDSIDtier, $WordIDcode);
                $WordIDcode = IncreaseIDcode($WordIDcode);
                if($TotalLineCount > 1)
                {
                    push(@WORDSstart, $WORDSend[-1]);
                    push(@WORDSend, ($WORDSstart[-1]+(1.5-$LineCount/$CorrectionQuotient)*$DeltaT));
                }
                else            # Single item (word) sentences
                {
                    push(@WORDSstart, $SentenceStart);
                    push(@WORDSend, $SentenceEnd);
                };
                
                ++$LineCount;   # Next word
                
                # Add a pause between words if required (the odd 1E-5 is for catching an eerie rounding error)
                if($ADDWORDPAUSE && $Word =~ /\w/ && $WORDSend[-1] + 1E-5 < $SentenceEnd)
                {
                    push(@WORDStier, '#');
                    push(@WORDSIDtier, $WordIDcode.'-1');
                    push(@WORDSstart, $WORDSend[-1]);
                    push(@WORDSend, ($WORDSstart[-1]+(1.5-$LineCount/$CorrectionQuotient)*$DeltaT));
                    
                    ++$LineCount;       # next word
                };
                
            };
        };
    }
    elsif(!@WORDSIDtier)
    {
        my $Translit = 0;
        # Initialize Word Code
        my $WordIDcode = $TRANSLITIDtier[$Translit].'1';
        
        my $Word;
        for($Word=0; $Word < scalar(@WORDStier); ++$Word)
        {
            if($WORDSstart[$Word] > $TRANSLITend[$Translit] - 0.01)
            {
                ++$Translit;
                $WordIDcode = $TRANSLITIDtier[$Translit].'1';
            };
            $WORDSIDtier[$Word] = $WordIDcode;
            $WordIDcode = IncreaseIDcode($WordIDcode);          
        };
    }
    else
    {
        InterpolateIDtier(\@WORDSIDtier);
    };
    
    
    #
    # Fill the Word CGN Tier from the Words Tier.
    #
    unless(@CGNtier)
    {
        my $Word;
        for($Word=0; $Word < scalar(@WORDStier); ++$Word)
        {
            my $Text = $WORDStier[$Word];
            #
            # Tranlate Text
            # Fixed pronunxiation
            if($FileID =~ /${ID}[12]FP[AB][12](VOW|HVD|VCV)/i)
            {
                $Text = lc($Text);
                if($FixedPronunciation{$Text})
                {
                    $Text = $FixedPronunciation{$Text};
                }
                elsif($Text =~ /^([aoeiuy]+)([^aoeiuy]+)([aoeiuy]+)$/)
                {
                    my $V1 = $1;
                    my $C = $2;
                    my $V2 = $3;
                    $V1 = 'aa' if $V1 eq 'a';
                    $V2 = 'aa' if $V2 eq 'a';
                    #
                    $Text = "$FixedPronunciation{$V1}-$FixedPronunciation{$C}$FixedPronunciation{$V2}";
                }
                else  # Unknown fixed pronunciation, translate anyway but print a warning
                {
                    
                    chomp($Text);
                    my $NewText = ::TranscribeCGNstring($Text) if $Text =~ /\S/;
                    chomp($NewText);
                
                    # Store unknown words and typo's for preprocessing
                    ++$UnknownWords{$Text} if $NewText =~ /\*[^\*]+\*/ && $NewText !~ /\*[x]/; # Unknown Words

                    # Warn about translation
                    print STDERR "Error, Fixed pronunciation unknown: '$Text' -> /$NewText/\n";

                    # Store translation
                    $Text = $NewText;
                };
            }
            elsif($FileID =~ /${ID}[12][FV]Y/i)
            {
                my $NewText = "";
                my $OldText = $Text;
                while($OldText)
                {
                    if(length($OldText) > 2 && $SyllableTranslit{$OldText})
                    {
                        $NewText .= $SyllableTranslit{$OldText};
                        $OldText = "";
                    }
                    elsif(length($OldText) >= 2 && $SyllableTranslit{substr($OldText, 0, 2)})
                    {
                        $NewText .= $SyllableTranslit{substr($OldText, 0, 2)};
                        $OldText = substr($OldText, 2);
                    }
                    elsif($SyllableTranslit{substr($OldText, 0, 1)})
                    {
                        $NewText .= $SyllableTranslit{substr($OldText, 0, 1)};
                        $OldText = substr($OldText, 1);
                    }
                    else
                    {
                        $NewText .= substr($OldText, 0, 1);
                        $OldText = substr($OldText, 1);
                    };
                };
                $Text = $NewText;
            }
            else
            {
                $Text =~ s/[\'\`]+/\'/g;
                my $NewText = ::TranscribeCGNstring($Text) if $Text =~ /\S/;
                
                # Store unknown words and typo's for preprocessing
                $UnknownWords{$Text} .= "$FileID " if $NewText =~ /\*[^\*]+\*/ && $NewText !~ /\*[x]/; # Unknown Words
                
                # Use the next line to identify typo's
                #print STDERR "$FileID: $Text\n" if $NewText =~ /\*[^\*]+\*/ && $NewText !~ /\*[ax]/;
                
                # Add plural /n/ to surface in "formal" speech
                $NewText =~ s/\@$/\@n/g if $FileID !~ /${ID}[12][FV][IR]/i && $NewText =~ /\@$/ && $Text =~ /en$/;
                
                # Ready, assign transcription
                $Text = $NewText;
            };
            
            # Clean up transcription
            $Text =~ s/[\[\]]//g;
            $Text =~ s/(^\s+)|(\s+$)//g;
            $Text =~ s/\s\s+/ /g;
            
            # 
            # Store Tier
            $CGNtier[$Word] = $Text;
            $CGNIDtier[$Word] = $WORDSIDtier[$Word];
            $CGNstart[$Word] = $WORDSstart[$Word];
            $CGNend[$Word]   = $WORDSend[$Word];
        };
        
    }
    elsif(!@CGNIDtier)
    {
        my $Word;
        for($Word=0; $Word < scalar(@WORDStier); ++$Word)
        {
            # Copy ID Tier
            $CGNIDtier[$Word] = $WORDSIDtier[$Word];
        };
    }
    else
    {
        InterpolateIDtier(\@CGNIDtier);
    };
    
    #
    # Fill the Syllables Tier from the CGN Tier.
    #
    unless(@SYLLABLEStier)
    {
        my $Word;
        for($Word=0; $Word < scalar(@CGNtier); ++$Word)
        {
            # Get word values
            my $WordText = $CGNtier[$Word];
            my $WordIDcode = $CGNIDtier[$Word];
            my $WordStart = $CGNstart[$Word];
            my $WordEnd = $CGNend[$Word];
            
            # Initialize ID code
            my $SyllableIDcode = $WordIDcode."S";
            
            # Handle ambiguities
            while($WordText =~ /\[\s*([^\]]*)\s*\]/)
            {
                my $Pre = $`;
                my $Match = $1;
                my $Post = $';
                my @AmbiguousWords = sort {length($a) <=> length($b)} split(' ', $Match);
                $Match = $AmbiguousWords[0];
                $WordText = $Pre.$Match.$Post;
            };
            # Split into syllables if there is a CGN translation
            my @AllSyllables = $WordText !~ /^\s*\*[^\*]*\*\s*$/ ? split(/[\-\s]+/, $WordText) : ($WordText);
            # Determine syllable length
            my $DeltaT = 0;
            $DeltaT = ($WordEnd - $WordStart)/scalar(@AllSyllables) if @AllSyllables;
            # Store Syllables in Syllables Tier
            my $Syllable;
            foreach $Syllable (@AllSyllables)
            {
                push(@SYLLABLEStier, $Syllable);
                push(@SYLLABLESIDtier, $SyllableIDcode);
                $SyllableIDcode = IncreaseIDcode($SyllableIDcode, 'S');
                push(@SYLLABLESstart, $SYLLABLESend[-1]);
                push(@SYLLABLESend, ($SYLLABLESstart[-1]+$DeltaT));
            };
            # Add 'F' for word final syllables
            $SYLLABLESIDtier[$#SYLLABLESIDtier] .= 'F' if @AllSyllables && @SYLLABLESIDtier;
        };
    }
    elsif(!@SYLLABLESIDtier)
    {
        my $Word = 0;
        # Initialize Syllable Code
        my $SyllableIDcode = $WORDSIDtier[$Word].'S';
        
        my $Syllable;
        for($Syllable=0; $Syllable < scalar(@SYLLABLEStier); ++$Syllable)
        {
            if($SYLLABLESstart[$Syllable] > $WORDSend[$Word] - 0.001)
            {
                ++$Word;
                $SyllableIDcode = $WORDSIDtier[$Word].'S';
                $SYLLABLESIDtier[$Syllable-1] .= 'F';                   # Word end marker
            };
            $SYLLABLESIDtier[$Syllable] = $SyllableIDcode;
            $SyllableIDcode = IncreaseIDcode($SyllableIDcode, 'S');             
        };
    }
    else
    {
        InterpolateIDtier(\@SYLLABLESIDtier);
    };
    
    #
    # Fill the Syllable Constituents Tier from the Syllable Tier.
    #
    unless(@SYLLPARTStier)
    {
        my $Syllable;
        for($Syllable=0; $Syllable < scalar(@SYLLABLEStier); ++$Syllable)
        {
            # Get Syllable values
            my $SyllableText = $SYLLABLEStier[$Syllable];
            my $SyllableIDcode = $SYLLABLESIDtier[$Syllable];
            my $SyllableStart = $SYLLABLESstart[$Syllable];
            my $SyllableEnd = $SYLLABLESend[$Syllable];
            
            my $PrevSyllableText = $Syllable && $SYLLABLESIDtier[$Syllable-1] !~ /F$/ 
            ? $SYLLABLEStier[$Syllable-1] : "";
            my $NextSyllableText = $SYLLABLESIDtier[$Syllable] !~ /F$/ ? $SYLLABLEStier[$Syllable+1] : "";
            
            # Remove Stress markers
            $SyllableText =~ s/[\'\"]//g;
            # Remove unknown words, replace by placeholder
            $SyllableText =~ s/^\s*\*[^\*]*\*\s*$/\*/g;
            # Split into Onset, Kernel and Offset
            $SyllableText =~ 
            /\s*([^\@AEIOQIYiyaeou29\|\}]*)([\@AEIOQIYiyaeou29\|\}]*[\+\~\:]?)([^\@AEIOQIYiyaeou29\|\}]*)\s*/is;
            my @AllParts = ();
            my @PartCodes = ();
            my $Onset = $1;
            my $Kernel = $2;
            my $Coda = $3;
            
            push(@AllParts, $Onset) if $Onset =~ /\S/;
            push(@PartCodes, 'O') if $Onset =~ /\S/;
            # Check for Ambisyllabicity
            $PartCodes[$#PartCodes] .= 'A' if @PartCodes && $Onset =~ /\S/ && ($PrevSyllableText =~ /\Q$Onset\E$/);
            
            push(@AllParts, $Kernel) if $Kernel =~ /\S/;
            push(@PartCodes, 'K') if $Kernel =~ /\S/;
            
            push(@AllParts, $Coda) if $Coda =~ /\S/;
            push(@PartCodes, 'C') if $Coda =~ /\S/;
            # Check for Ambisyllabicity
            $PartCodes[$#PartCodes] .= 'A' if @PartCodes && $Coda =~ /\S/ && ($NextSyllableText =~ /^[\"\']*\Q$Coda\E/);
            # Determine syllable Part length
            my $DeltaT = ($SyllableEnd - $SyllableStart)/(scalar(@AllParts)) if @AllParts;
            
            # Store Part in SYLLPARTS Tier
            my $Part;
            foreach $Part (@AllParts)
            {
                push(@SYLLPARTSstart, $SYLLPARTSend[-1]);
                push(@SYLLPARTSend, ($SYLLPARTSstart[-1]+$DeltaT));     
                
                push(@SYLLPARTStier, $Part);
                push(@SYLLPARTSIDtier, $SyllableIDcode.(shift(@PartCodes)));
            };
        };
    }
    elsif(!@SYLLPARTSIDtier)
    {
        my $Syllable = 0;
        # Initialize SyllablePart Code
        my $SyllablePartIDcode = $SYLLABLESIDtier[$Syllable];
        
        my $SyllablePart;
        for($SyllablePart=0; $SyllablePart < scalar(@SYLLPARTStier); ++$SyllablePart)
        {
            # First, check for perfect alignment
            # Start of Syllable
            if(abs($SYLLPARTSstart[$SyllablePart] - $SYLLABLESstart[$Syllable]) < 0.001)
            {
                $SyllablePartIDcode = ($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                ? 'K' : 'O';
            }
            # End of Syllable
            elsif(abs($SYLLPARTSend[$SyllablePart] - $SYLLABLESend[$Syllable]) < 0.001)
            {
                $SyllablePartIDcode = ($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                ? 'K' : 'C';
            }
            # Next Syllable
            elsif(abs($SYLLPARTSstart[$SyllablePart] - $SYLLABLESend[$Syllable]) < 0.001)
            {
                ++$Syllable;
                $SyllablePartIDcode = ($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                ? 'K' : 'O';
            }
            # Same content
            # Onset
            elsif($SYLLABLEStier[$Syllable] =~ /^\Q$SYLLPARTStier[$SyllablePart]\E/)
            {
                $SyllablePartIDcode = ($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                ? 'K' : 'O';
            }
            # Offset
            elsif($SYLLABLEStier[$Syllable] =~ /\Q$SYLLPARTStier[$SyllablePart]\E$/)
            {
                $SyllablePartIDcode = ($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                ? 'K' : 'C';
            }
            # Kernel?
            elsif($SYLLABLEStier[$Syllable] =~ /\Q$SYLLPARTStier[$SyllablePart]\E/)
            {
                if($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                {
                    $SyllablePartIDcode = 'K';
                }
                elsif($SYLLABLEStier[$Syllable] =~ 
                /[\/\@AEIOQIYiyaeou29\|\}][\+\~\:]?.*\Q$SYLLPARTStier[$SyllablePart]\E/)
                {
                    $SyllablePartIDcode = 'C';
                }
                elsif($SYLLABLEStier[$Syllable] =~ 
                /\Q$SYLLPARTStier[$SyllablePart]\E.*[\/\@AEIOQIYiyaeou29\|\}][\+\~\:]?/)
                {
                    $SyllablePartIDcode = 'O';
                }
                else
                {
                    $SyllablePartIDcode = 'O';
                };
                
            }
            # An onset
            elsif($SYLLPARTStier[$SyllablePart] !~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SyllablePartIDcode =~ /CA?$/)
            {
                ++$Syllable;
                $SyllablePartIDcode = 'O';
            }
            # A new syllable kernel
            elsif($SYLLPARTStier[$SyllablePart] =~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SyllablePartIDcode !~ /OA?$/)
            {
                ++$Syllable;
                $SyllablePartIDcode = 'K';
            }
            # A syllable kernel
            elsif($SYLLPARTtier[$SyllaPart] =~ /[\@AEIOQIYiyaeou29\|\}]*[\+\~\:]?/)
            {
                $SyllablePartIDcode = 'K';
            }
            elsif($SyllablePartIDcode eq 'K')
            {
                $SyllablePartIDcode = 'C';      
            }
            else
            {
                die "Unresolved: $SYLLPARTSIDtier[$SyllablePart] = $SYLLABLESIDtier[$Syllable].$SyllablePartIDcode\n";
            };
            
            # Add id code
            $SYLLPARTSIDtier[$SyllablePart] = $SYLLABLESIDtier[$Syllable].$SyllablePartIDcode;
        };
    }
    else
    {
        InterpolateIDtier(\@SYLLPARTSIDtier);
    };
    
    #
    # Fill the Phonemes Tier from the SYLLPARTS Tier.
    #
    unless(@PHONEMEStier)
    {
        my $SyllablePart;
        for($SyllablePart=0; $SyllablePart < scalar(@SYLLPARTStier); ++$SyllablePart)
        {
            # Get Syllable values
            my $SyllablePartText = $SYLLPARTStier[$SyllablePart];
            my $SyllablePartIDcode = $SYLLPARTSIDtier[$SyllablePart];
            my $SyllablePartStart = $SYLLPARTSstart[$SyllablePart];
            my $SyllablePartEnd = $SYLLPARTSend[$SyllablePart];
            
            # Concatenate diphthongs and \: lengthening
            $SyllablePartText =~ s/[\'\"]//g;   # Remove stress markers
            
            # Split into phonemes, if there are phonemes
            $SyllablePartText =~ s/^\s*\*[^\*]*\*\s*$/\*/g;
            $SyllablePartText =~ s/([\/\@AEIOQIYiyaeou29\|\}]{2}|\S[\+\~\:]?)/ $1 /isg;
            
            my @AllPhonemes = grep(/\S/, split(' ', $SyllablePartText));
            # Determine syllable part length
            my $DeltaT = ($SyllablePartEnd - $SyllablePartStart)/scalar(@AllPhonemes);
            # Store Phonemes in Phonemes Tier
            my $PhonemeIDcode = $SyllablePartIDcode."1";
            my $Phoneme;
            foreach $Phoneme (@AllPhonemes)
            {
                push(@PHONEMEStier, $Phoneme);
                push(@PHONEMESIDtier, $PhonemeIDcode);
                $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);
                push(@PHONEMESstart, $PHONEMESend[-1]);
                push(@PHONEMESend, ($PHONEMESstart[-1]+$DeltaT));
            }; 
        };
    }
    elsif(!@PHONEMESIDtier)
    {
        my $SyllablePart = 0;
        # Initialize Phoneme Code
        my $PhonemeIDcode = $SYLLABLESIDtier[$SyllablePart].'1';
        my $SyllablePartText = "";
        my $SyllPartcode = 'O';
        
        my $Phoneme = 0;
        
        while($Phoneme < scalar(@PHONEMEStier) && $SyllablePart < scalar(@SYLLPARTStier))
        {
            # The easy part: The phoneme is actually present in the Syllable
            while($SYLLPARTStier[$SyllablePart] =~ /\Q$PHONEMEStier[$Phoneme]\E/
            && $SyllablePartText !~ /\Q$PHONEMEStier[$Phoneme]\E/)
            {
                $SyllablePartText .= $PHONEMEStier[$Phoneme];
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);
                
                # Only one phoneme per kernel
                if($PHONEMEStier[$Phoneme] =~ /[\/\@AEIOQIYiyaeou29\|\}]/)
                {
                    ++$SyllablePart;
                    $SyllablePartText = "";
                    $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
                };
                
                ++$Phoneme;
            };
            
            # Still easy, the phoneme is already part of the current part
            # so it has to be in the next part
            if($SyllablePartText =~ /\Q$PHONEMEStier[$Phoneme]\E/)
            {
                ++$SyllablePart;
                $SyllablePartText = "";
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
            }
            # The current phoneme is a vowel, but the syllable part specifies a consonant
            elsif($PHONEMEStier[$Phoneme] =~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SYLLPARTSIDtier[$SyllablePart] !~ /KA?$/)
            {
                # Dangerous, remove any empty part
                if(!$SyllablePartText)
                {
                    # Delete the syllable part
                    splice(@SYLLPARTStier, $SyllablePart, 1);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 1);
                    $SYLLPARTSstart[$SyllablePart+1] = $SYLLPARTSstart[$SyllablePart];
                    splice(@SYLLPARTSstart, $SyllablePart, 1);
                    splice(@SYLLPARTSend, $SyllablePart, 1);
                }
                else    # Select next part
                {
                    ++$SyllablePart;
                };
                
                # Update text and phoneme
                $SyllablePartText = "";
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
            }
            # The current phoneme is a vowel and the syllable part specifies a vowel
            elsif($PHONEMEStier[$Phoneme] =~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SYLLPARTSIDtier[$SyllablePart] =~ /KA?$/)
            {
                # Current kernel not specified, a SUBSTITUTION
                if(!$SyllablePartText)
                {
                    $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                    $SYLLPARTStier[$SyllablePart] = $PHONEMEStier[$Phoneme];
                    ++$Phoneme;
                    ++$SyllablePart;
                }
                else    # Current kernel filled, select next part
                {
                    ++$SyllablePart;
                };
                
                # Update text and phoneme
                $SyllablePartText = "";
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
            }
            # A consonant inserted BEFORE the current part
            # If the START of a consonant is aligned with the START of the current part, it must be inserted
            elsif($PHONEMEStier[$Phoneme] !~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && abs($PHONEMESstart[$Phoneme] - $SYLLPARTSstart[$SyllablePart]) < 0.001)
            {
                # It should become BEFORE the kernel (onset)
                if($SYLLPARTSIDtier[$SyllablePart] =~ /KA?$/)
                {
                    splice(@SYLLPARTStier,   $SyllablePart, 0, $SYLLPARTStier[$SyllablePart]);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 0, $SYLLPARTSIDtier[$SyllablePart]);
                    splice(@SYLLPARTSstart,  $SyllablePart, 0, $SYLLPARTSstart[$SyllablePart]);
                    splice(@SYLLPARTSend,    $SyllablePart, 0, $SYLLPARTSend[$SyllablePart]);
                    
                    $SYLLPARTStier[$SyllablePart] = $PHONEMEStier[$Phoneme];
                    $SYLLPARTSIDtier[$SyllablePart] =~ s/K(A?)$/O$1/g;
                    $SYLLPARTSend[$SyllablePart] = 
                    ($SYLLPARTSend[$SyllablePart] - $SYLLPARTSstart[$SyllablePart])/2;
                    $SYLLPARTSstart[$SyllablePart+1] = $SYLLPARTSend[$SyllablePart];    
                    $SyllablePartText = "";
                };
                #
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $SyllablePartText .= $PHONEMEStier[$Phoneme];
                ++$Phoneme;
            }
            # A consonant inserted AFTER the current part
            # If a END of a consonant is aligned with the START of the current part, it must be inserted
            elsif($PHONEMEStier[$Phoneme] !~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && abs($PHONEMESend[$Phoneme] - $SYLLPARTSstart[$SyllablePart]) < 0.001)
            {
                # Go back to the previous syllable Part and copy it
                --$SyllablePart;
                # It should become AFTER the previous kernel (coda)
                if($SYLLPARTSIDtier[$SyllablePart] =~ /KA?$/)
                {
                    splice(@SYLLPARTStier,   $SyllablePart, 0, $SYLLPARTStier[$SyllablePart]);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 0, $SYLLPARTSIDtier[$SyllablePart]);
                    splice(@SYLLPARTSstart,  $SyllablePart, 0, $SYLLPARTSstart[$SyllablePart]);
                    splice(@SYLLPARTSend,    $SyllablePart, 0, $SYLLPARTSend[$SyllablePart]);
                    
                    # Go to copy syllable part
                    ++$SyllablePart;
                    $SYLLPARTStier[$SyllablePart] = $PHONEMEStier[$Phoneme];
                    $SYLLPARTSIDtier[$SyllablePart] =~ s/K(A?)$/C$1/g;
                    $SYLLPARTSend[$SyllablePart-1] = 
                    ($SYLLPARTSend[$SyllablePart] - $SYLLPARTSstart[$SyllablePart-1])/2;
                    $SYLLPARTSstart[$SyllablePart] = $SYLLPARTSend[$SyllablePart-1];    
                    $SyllablePartText = "";
                };
                #
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $SyllablePartText .= $PHONEMEStier[$Phoneme];
                ++$Phoneme;
            }
            # Still easy, the phoneme is part of the next syllable part and is ambisyllabic
            # (contains an _)
            elsif($PHONEMEStier[$Phoneme] =~ /\_/)
            {
                # It should become BEFORE the kernel (onset)
                if($SYLLPARTSIDtier[$SyllablePart] =~ /KA?$/)
                {
                    splice(@SYLLPARTStier,   $SyllablePart, 0, $SYLLPARTStier[$SyllablePart]);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 0, $SYLLPARTSIDtier[$SyllablePart]);
                    splice(@SYLLPARTSstart,  $SyllablePart, 0, $SYLLPARTSstart[$SyllablePart]);
                    splice(@SYLLPARTSend,    $SyllablePart, 0, $SYLLPARTSend[$SyllablePart]);
                    
                    $SYLLPARTStier[$SyllablePart] = $PHONEMEStier[$Phoneme];
                    $SYLLPARTSIDtier[$SyllablePart] =~ s/K(A?)$/O$1/g;
                    $SYLLPARTSend[$SyllablePart] = 
                    ($SYLLPARTSend[$SyllablePart] - $SYLLPARTSstart[$SyllablePart])/2;
                    $SYLLPARTSstart[$SyllablePart+1] = $SYLLPARTSend[$SyllablePart];    
                    $SyllablePartText = "";
                }
                # Dangerous, remove any empty part
                elsif(!$SyllablePartText && $SYLLPARTSIDtier[$SyllablePart] =~ /CA?$/)
                {
                    # Delete the syllable part
                    splice(@SYLLPARTStier, $SyllablePart, 1);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 1);
                    $SYLLPARTSstart[$SyllablePart+1] = $SYLLPARTSstart[$SyllablePart];
                    splice(@SYLLPARTSstart, $SyllablePart, 1);
                    splice(@SYLLPARTSend, $SyllablePart, 1);
                }
                elsif($SyllablePartText && $SYLLPARTSIDtier[$SyllablePart] =~ /CA?$/)
                {
                    # Look whether next part is an Onset
                    ++$SyllablePart;
                }
                else    # Use Onset
                {
                    #
                    $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'A1';
                    $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                    $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);                    
                    $SyllablePartText = $PHONEMEStier[$Phoneme];
                    ++$Phoneme;
                };
            }
            # Still easy, the phoneme is part of the next syllable part (and not identical to
            # the next phoneme, e.g., assimilated)
            elsif($SYLLPARTStier[$SyllablePart+1] =~ /\Q$PHONEMEStier[$Phoneme]\E/
            && $PHONEMEStier[$Phoneme] !~ /\Q$PHONEMEStier[$Phoneme+1]\E/)
            {
                # Dangerous, remove any empty part
                if(!$SyllablePartText)
                {
                    # Delete the syllable part
                    splice(@SYLLPARTStier, $SyllablePart, 1);
                    splice(@SYLLPARTSIDtier, $SyllablePart, 1);
                    $SYLLPARTSstart[$SyllablePart+1] = $SYLLPARTSstart[$SyllablePart];
                    splice(@SYLLPARTSstart, $SyllablePart, 1);
                    splice(@SYLLPARTSend, $SyllablePart, 1);
                }
                else    # Select next part
                {
                    ++$SyllablePart;
                };
                
                # Update text and phoneme
                $SyllablePartText = $PHONEMEStier[$Phoneme];
                $PhonemeIDcode = $SYLLPARTSIDtier[$SyllablePart].'1';
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);                        
                ++$Phoneme;
            }
            # Consonant Substitution or insertion in onset
            elsif($PHONEMEStier[$Phoneme] !~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SYLLPARTSIDtier[$SyllablePart] =~ /[OK]A?$/
            && $Sonority{$PHONEMEStier[$Phoneme]} <= $Sonority{$PHONEMEStier[$Phoneme+1]})
            {
                $SyllablePartText .= $PHONEMEStier[$Phoneme];
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);
                ++$Phoneme;
            }
            # Consonant Substitution or Insertion in coda
            elsif($PHONEMEStier[$Phoneme] !~ /[\/\@AEIOQIYiyaeou29\|\}]/
            && $SYLLPARTSIDtier[$SyllablePart] =~ /CA?$/
            && $Sonority{$PHONEMEStier[$Phoneme]} <= $Sonority{$PHONEMEStier[$Phoneme-1]})
            {
                $SyllablePartText .= $PHONEMEStier[$Phoneme];
                $PHONEMESIDtier[$Phoneme] = $PhonemeIDcode;
                $PhonemeIDcode = IncreaseIDcode($PhonemeIDcode);
                ++$Phoneme;
            }
            # Make sure something happens
            else
            {
                die "Spin: $Phoneme $PHONEMESIDtier[$Phoneme] $PHONEMEStier[$Phoneme] ",
                "$SyllablePart $SYLLPARTSIDtier[$SyllablePart] $SYLLPARTStier[$SyllablePart]\n";
            };
        };
    }
    else
    {
        InterpolateIDtier(\@PHONEMESIDtier);
    };
    
    
    #
    # Make formatted (Praat) output
    #
    # First: Open the file
    open(TARGET, ">$PhonemeLabels$ID/$LabelType/$FileID.$LabelType") || 
    die ">$PhonemeLabels$ID/$LabelType/$FileID.$LabelType: $!\n";
    
    ++$FilesWritten;  # Keep track of number of files actually written
    
    # Get the names of the requested tiers
    my @PrintedTiers = ('WORDS', 'SYLLABLES', 'PHONEMES');
    
    my $i;
    print TARGET << "LABELEND";
File type = "ooTextFile short"
"TextGrid"

0
$DURATION
<exists>
LABELEND
    
    my $NumberOfTiers = 0;
    my $Tier;
    
    foreach $Tier (@PrintedTiers) { eval("\$NumberOfTiers += (\$$Tier =~ /ID\$/) ? 2 : 1;");};
    print TARGET "$NumberOfTiers\n";
    
    my $Tier;
    foreach $Tier (reverse(@PrintedTiers))
    {
        # Now here an ugly clutch to work around being unable to construct variable names
        my $CurrentTier; eval('$CurrentTier = \@{'.$Tier.'tier'.'};');
        my $CurrentIDTier; eval('$CurrentIDTier = \@{'.$Tier.'IDtier'.'};');
        my $CurrentStart; eval('$CurrentStart = \@{'.$Tier.'start'.'};');
        my $CurrentEnd; eval('$CurrentEnd = \@{'.$Tier.'end'.'};');
        my $PrintFoldedIDcode = 0; eval('$PrintFoldedIDcode = ($'.$Tier.' =~ /IDFOLDED$/i);'); 
        # The tier with the values
        print TARGET "\"IntervalTier\"\n";
        print TARGET "\"$Tier\"\n";
        print TARGET "0\n";
        print TARGET "$DURATION\n";
        print TARGET scalar(@$CurrentTier), "\n";
        
        my $Interval;
        for($Inteval=0; $Interval < scalar(@$CurrentTier); ++$Interval)
        {
            print TARGET $$CurrentStart[$Interval] ? $$CurrentStart[$Interval] : '0', "\n";
            print TARGET "$$CurrentEnd[$Interval]\n";
            my $PrintText = "";
            # Fold the ID codes into the tier labels
            $PrintText .= $$CurrentTier[$Interval];
            $PrintText .= '__' . $$CurrentIDTier[$Interval] if $PrintFoldedIDcode;                      
            $PrintText =~ s/([\'\"\`])/$1$1/g;
            print TARGET "\"$PrintText\"\n";
        };
        
        # Skip the item codes unless they are required
        my $ItemCode = eval("\$$Tier;");
        next unless $ItemCode =~ /ID$/;
        
        # The tier with the IDcodes
        print TARGET "\"IntervalTier\"\n";
        print TARGET "\"${Tier}ID\"\n";
        print TARGET "0\n";
        print TARGET "$DURATION\n";
        print TARGET scalar(@$CurrentIDTier), "\n";
        
        my $Interval;
        for($Inteval=0; $Interval < scalar(@$CurrentIDTier); ++$Interval)
        {
            print TARGET $$CurrentStart[$Interval] ? $$CurrentStart[$Interval] : '0', "\n";
            print TARGET "$$CurrentEnd[$Interval]\n";
            print TARGET "\"$$CurrentIDTier[$Interval]\"\n";
        };
    };
    
    close(TARGET);
    
    return %UnknownWords;
};

sub Split_All_Sentences # ($ID) -> 0/1;
{
    my $ID = shift || return ();
    
    my %AllUnknownWords = ();
    my $word;
    
    #
    # Run Fixed transcription list through TranscribeCGN
    open(TRANSCRIPTION, "<FixedLexemes.txt");
    while(<TRANSCRIPTION>)
    {
        ::TranscribeCGNstring($_);
    };
    
    my @FileList = glob("${SentenceLabels}$ID/translit/*.translit");
    foreach $FilePath (@FileList)
    {
        $FilePath =~ m@/([^/]+)$@;
        my $FileName = $1;
        $FileName =~ s/\.[\w]+$//ig;
        die "$FilePath does not contain a filename\n" unless $FileName =~ /\w/;
        next if -e "${PhonemeLabels}prephoneme/$ID/$FileName.prephoneme";
        
        $ADDWORDPAUSE = $FileName =~ /${ID}[12](FP[AB]|[FV][WY])/ ? 1 : 0;
        my %CurrentUnknownWords = transcribe_translit_file($ID, $FileName);
        
        foreach $word (keys(%CurrentUnknownWords))
        {
            $AllUnknownWords{$word} .= $CurrentUnknownWords{$word}." ";
        };
    };
    
    foreach $word (keys(%AllUnknownWords))
    {
        print STDERR "$word - $AllUnknownWords{$word}\n" if $word; #  && $word !~ /\*v\s+/;  # Skip foreign words
    };
    
    print STDERR "Number of files created: $FilesWritten\n";
    
    return 1;
};

#
my $ID = shift(@ARGV) || exit;

Split_All_Sentences($ID);

