#! /usr/bin/perl
#
# Special purpose program for Unix/Linux, NEEDS praat:
# Read all arguments as sound files, get the corresponding label files and zero out
# the sentence margins. Write the resulting files as Raw sound files:
#    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
#
my $SampleRate = 8000;		# Sample Frequency in Hz
my $Encoding = 'Linear';  # Encoding
my $BitWidth = "16-bit";  # Number of bits per sample
my $Endian = "big-endian";# Byte order
#
# Use:
# The speech files are in ./Speech/fm/<SpeakerID>/
# The label files are in ./Labels/<SpeakerID>/
# The results will be placed in: ./Converted/<SpeakerID>/
#
# Call:
# ./ZeroSentenceMargins.pl ./Speech/fm/F28G/F28G1FPA*
#
# This will convert all files in F28G whose names start with 'F28G1FPA'
#
package SentenceLabel;

sub new
{
    my $type = shift;
    my $self = {};
    $self->{'TIER'} = {};	# The tier content
    $self->{'ID'} = {};		# The tier ID codes
    $self->{'START'} = {};	# The tier Start times
    $self->{'END'} = {};	# The tier End times
    $self->{'TIERPOINTER'} = {};	# The current position in the tiers
    $self->{'RESETPOINTER'} = {};	# The current position in the tiers
    $self->{'CURRENTTIER'} = "";	# The default Tier
    $self->{'FoldedIDcodes'} = [];	# Print folded ID codes?
    $self->{'IDcodeTiers'} = [];	# Print ID codes in separate tiers
    $self->{'SentenceIDcode'} = "";	# The MASTER sentence ID code
    #   
    return bless($self);
};

########################################################################
#
# Some simple methods for handling tiers
# 
# Tier level functions:
# NumberOfTiers ()  -> Number
# existsTier (Tier) -> 1/0
# createTier ($Tier) -> $Tier or -1 (if unsuccesfull)
# TierLength  (Tier) -> number_of_items
# duration (Tier) -> duration in seconds (or "")
#
# Position and move around a tier, if a new position is
# not inside the tier, all functions return a -1:
# currentItem (Tier) -> current_index_number
# currentValue (Tier) -> current_value
# currentIDcode (Tier) -> current_IDcode
# currentParentIDcode (Tier) -> current_parent_IDcode
# currentStart (Tier) -> current_StartTime
# currentEnd (Tier) -> current_EndTime
# setItem (Tier, Index) -> new_index_number
# nextItem (Tier) -> next_index_number
# previousItem (Tier) -> previous_index_number
# presetItem (Tier) -> -1
# firstItem (Tier) -> 0
# lastItem (Tier) -> LastItem
#
# Delete and insert:
# removeItem ($Tier) -> Current item
# pushItem ($Tier, $Value, $IDcode, $Start, $End) -> Index of new item
# insertItemAfter ($Tier, $Value, $ID, $EndTime) -> current_index_number
# insertItemBefore ($Tier, $Value, $ID, $StartTime) -> current_index_number
#
# Find specific items by "value":
# locateID ($Tier, $IDcode) -> SpecificItem (or -1 if not found)
# nextParentID($Tier, $ParentIDcode) -> SpecificItem (or -1 if not found)
# previousParentID($Tier, $ParentIDcode) -> SpecificItem (or -1 if not found)
# grepnextValue ($Tier, $RegExpPattern) -> Index or -1
# grepnextID ($Tier, $RegExpPattern) -> Index or -1
# grepprevValue ($Tier, $RegExpPattern) -> Index or -1
# grepprevID ($Tier, $RegExpPattern) -> Index or -1
#
########################################################################
#
# Return the number of tiers
sub NumberOfTiers	# () -> Number
{
    my $self = shift;
    return scalar(keys(%{$self->{TIER}}));
}

# Tier exists
sub existsTier	# (Tier) -> 1/0
{
    my $self = shift;
    my $Tier = shift || return 0;
    
    # Check existence
    my $TierExists = exists($self->{TIER}{$Tier});
    
    # Set new default tier
    $self->{CURRENTTIER} = $Tier if $TierExists;
    
    # Does Tier actually exist?
    return $TierExists;
}

# Create a new Tier. 
# Returns -1 if Tier already exists.
sub createTier	# ($Tier) -> $Tier or -1 (if unsuccesfull)
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;

    return -1 if $self->existsTier($Tier);
    
    # Create and empty tier
    $self->{TIER}{$Tier} = [];
    $self->{ID}{$Tier} = [];
    $self->{START}{$Tier} = [];
    $self->{END}{$Tier} = [];
    $self->{TIERPOINTER}{$Tier} = -1;
    $self->{RESETPOINTER}{$Tier} = [];
    $self->{TOLERANCE} = 0.0005;         # Tolerance for alignment
    
    return $Tier;
}


# Length of a tier
sub TierLength	# (Tier) -> number_of_items
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    return scalar(@{$self->{TIER}{$Tier}});
}

# Total duration of a tier
sub duration	# (Tier) -> duration in seconds (or "")
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    # Does Tier actually exist?
    return "" unless $self->existsTier($Tier) && $self->TierLength($Tier) > 0;
    
    my $duration = $self->{END}{$Tier}[$self->TierLength($Tier)-1] 
           - $self->{START}{$Tier}[0];
	   
    return $duration;
}

# Current Item index. Also checks the upper boundary.
sub currentItem	# (Tier [, $Index]) -> current_index_number
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Set a new value if there is a second argument
    if(@_)
    {
        $self->{TIERPOINTER}{$Tier} = shift || 0;
    };
    
    # Has someone messed around with the Tier (check boundaries)?
    $self->{TIERPOINTER}{$Tier} = -1 if $self->{TIERPOINTER}{$Tier} < -1;
    $self->{TIERPOINTER}{$Tier} = -1 unless $self->{TIERPOINTER}{$Tier} < $self->TierLength($Tier);
    
    return $self->{TIERPOINTER}{$Tier};
}

# Current Item value
sub currentValue	# (Tier [, $Value]) -> current_value
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return "";
    
    # Does Tier actually exist?
    return "" unless 
    $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    # Set a new value if there is a second argument
    if(@_)
    {
        $self->{TIER}{$Tier}[$self->currentItem($Tier)] = shift || 0;
    };
    
    return $self->{TIER}{$Tier}[$self->currentItem($Tier)];
}

# Current Item ID
sub currentIDcode	# (Tier [, $IDcode]) -> current_IDcode
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return "";
    
    # Does Tier actually exist?
    return "" unless 
    $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    # Set a new value if there is a second argument
    if(@_)
    {
        $self->{ID}{$Tier}[$self->currentItem($Tier)] = shift || 0;
    };
    
    return $self->{ID}{$Tier}[$self->currentItem($Tier)];
}

# Current Item ID (needs a ParentIDcode() function)
sub currentParentIDcode	# (Tier) -> current_parent_IDcode
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return "";
    
    # Does Tier actually exist?
    return "" unless 
    $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    return &ParentIDcode($self->{ID}{$Tier}[$self->currentItem($Tier)]);
}

# Current Start time
sub currentStart	# (Tier [, $Start]) -> current_StartTime
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return "";
    
    # Does Tier actually exist?
    return "" unless 
    $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    # Set a new value if there is a second argument
    if(@_)
    {
        $self->{START}{$Tier}[$self->currentItem($Tier)] = shift || 0;
    };
    
    return $self->{START}{$Tier}[$self->currentItem($Tier)];
}

# Current End time
sub currentEnd	# (Tier [, $End]) -> current_EndTime
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return "";
    
    # Does Tier actually exist?
    return "" unless 
    $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    # Set a new value if there is a second argument
    if(@_)
    {
        $self->{END}{$Tier}[$self->currentItem($Tier)] = shift || 0;
    };
    
    return $self->{END}{$Tier}[$self->currentItem($Tier)];
}

#
# Set the Item index to a specific Index
sub setItem   # ($Tier, $Index) -> New_Item
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Index = shift || 0;
    
    # Note: currentItem checks for  boundaries!!!
    return $self->currentItem($Tier, $Index);
}

#
# Store the current Item index (push it on an unlimited stack)
sub storeItem   # ($Tier) -> New_Item
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Index = shift || 0;

    # Store the index
    push(@{$self->{RESETPOINTER}{$Tier}}, $self->currentItem($Tier));
    
    # Note: currentItem checks for  boundaries!!!
    return $self->currentItem($Tier);
}

#
# Set the Item index to a stored Index (and pop it from the stack)
sub restoreItem   # ($Tier, $Index) -> New_Item
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Index = shift || 0;
    
    # Note: currentItem checks for  boundaries!!!
    return $self->currentItem($Tier, pop(@{$self->{RESETPOINTER}{$Tier}}));
}

# Step through a tier. -1 Is outside Tier
# Forwards
sub nextItem	# (Tier) -> next_index_number
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    # Note: currentItem checks for boundaries!!!
    return $self->currentItem($Tier, $self->currentItem($Tier) + 1);
}

# Backwards
sub previousItem	# (Tier) -> previous_index_number
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    my $CurrentItem = $self->currentItem($Tier);
    
    $CurrentItem = $self->TierLength($Tier) if $CurrentItem < 0;
    --$CurrentItem;

    return $self->currentItem($Tier, $CurrentItem);
}

# Start BEFORE the first item or after the last one
# (this is needed to start functions that use nextItem and previousItem
# on the correct item)
sub presetItem	# (Tier) -> -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    return $self->currentItem($Tier, -1);
}

# Start at first item
sub firstItem	# (Tier) -> 0
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    return $self->currentItem($Tier, 0);
}

# Jump to last item
sub lastItem	# (Tier) -> LastItem
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    return $self->currentItem($Tier, $self->TierLength($Tier) - 1);
}

# Remove the current item. The start of the next item
# will be set to the start of the removed item. Will move to
# the next item or -1 if there is no next item
sub removeItem     # ($Tier) -> Current item
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # If not the LAST item in the tier
    my $IsLast = 0;
    if($self->TierLength($Tier) > $self->currentItem($Tier))
    {
    	# Adjust the start of the next item
    	$self->{START}{$Tier}[$self->currentItem($Tier)+1] = 
	$self->currentStart($Tier);
    };
    
    # Remove item
    splice(@{$self->{TIER}{$Tier}}, $self->currentItem($Tier), 1);
    splice(@{$self->{ID}{$Tier}}, $self->currentItem($Tier), 1);
    splice(@{$self->{START}{$Tier}}, $self->currentItem($Tier), 1);
    splice(@{$self->{END}{$Tier}}, $self->currentItem($Tier), 1);
    
    return $self->currentItem($Tier);    
}

#
# Push a new item on the end of a Tier. Does NOT do any
# sanity checks! Also does NOT alter the current Item pointer,
# i.e., $self->currentItem($Tier) will NOT change.
#
sub pushItem     # ($Tier, $Value, $IDcode, $Start, $End) -> Index of new item
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my ($Value, $IDcode, $Start, $End) = @_;

    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Push item
    push(@{$self->{TIER}{$Tier}}, $Value);
    push(@{$self->{ID}{$Tier}}, $IDcode);
    push(@{$self->{START}{$Tier}}, $Start);
    push(@{$self->{END}{$Tier}}, $End);
    
    # Ready
    return $self->TierLength($Tier) - 1;
}

# Insert a new item after the current item.
# The start point of the new item will be the end point of 
# the current item. The start point of the NEXT item will be 
# the end point of the current item. 
# IT IS AN ERROR (-1) IF THE NEW END POINT IS BEYOND THE END
# OF THE NEXT ITEM. THE OPERATION IS ABORTED IN THIS CASE.
# Returns the Index of the new item, which will be the currentItem, or -1.
#
# If the currentItem == -1, the new item will become the first item of the
# tier.
sub insertItemAfter	# ($Tier, $Value, $ID, $EndTime) -> current_index_number
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my ($Value, $IDcode, $End) = @_;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # If not the LAST item in the tier
    if($self->TierLength($Tier) > $self->currentItem($Tier))
    {
        # Is the new End not beyond the next item
    	return -1 
	unless $self->{END}{$Tier}[$self->currentItem($Tier) + 1] < $End;
    	# Adjust the start of the next item
    	$self->{START}{$Tier}[$self->currentItem($Tier)+1] = $End;
    };
    
    # Insert item
    splice(@{$self->{TIER}{$Tier}}, $self->currentItem($Tier)+1, 0, $Value);
    splice(@{$self->{ID}{$Tier}}, $self->currentItem($Tier)+1, 0, $IDcode);
    splice(@{$self->{START}{$Tier}}, $self->currentItem($Tier)+1, 0, 
    					$self->currentEnd($Tier));
    splice(@{$self->{END}{$Tier}}, $self->currentItem($Tier)+1, 0, $End);
    
    return $self->nextItem($Tier);    
}

# Insert a new item before the current item.
# The end point of the new item will be the start point of 
# the current item. The end point of the PREVIOUS item will be 
# the start point of the current item. 
# IT IS AN ERROR (-1) IF THE NEW START POINT IS BEYOND THE START
# OF THE PREVIOUS ITEM. THE OPERATION IS ABORTED IN THIS CASE.
# Returns the Index of the new item, which will be the currentItem, or -1.
#
# If the currentItem == -1, the operation is aborted.
#
sub insertItemBefore	# ($Tier, $Value, $ID, $StartTime) -> current_index_number
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my ($Value, $IDcode, $Start) = @_;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier) && $self->currentItem($Tier) >= 0;
    
    # If not the FIRST item in the tier
    if($self->currentItem($Tier) > 0)
    {
        # Is the new End not beyond the previous item
    	return -1 
	unless $self->{START}{$Tier}[$self->currentItem($Tier) -1 ] > $Start;
    	# Adjust the start of the previous item
    	$self->{START}{$Tier}[$self->currentItem($Tier) - 1] = $Start;
    };
    
    # Insert item
    splice(@{$self->{TIER}{$Tier}}, $self->currentItem($Tier), 0, $Value);
    splice(@{$self->{ID}{$Tier}}, $self->currentItem($Tier), 0, $IDcode);
    splice(@{$self->{START}{$Tier}}, $self->currentItem($Tier), 0, $Start);
    splice(@{$self->{END}{$Tier}}, $self->currentItem($Tier), 0,  
    					$self->currentStart($Tier));
    
    return $self->currentItem($Tier);    
}

# Jump to specific ID (no ID -> start)
sub locateID	# ($Tier, $IDcode) -> SpecificItem (or -1 if not found)
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $IDcode = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate ID
    return -1 if $self->firstItem < 0;
    return $self->currentItem($Tier) unless $IDcode;

    while($self->currentID($Tier) ne $IDcode)
    {
        return -1 if $self->nextItem($Tier) < 0;  # NOT FOUND
    };
    
    return $self->currentItem($Tier);
}

# Jump to specific parent ID (no ID -> start)
sub locateParentID # ($Tier, $ParentIDcode) -> SpecificItem (or -1 if not found)
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $ParentIDcode = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate ID
    return -1 if $self->firstItem < 0;
    return $self->currentItem($Tier) unless $ParentIDcode;

    while($self->currentParentID($Tier) ne $ParentIDcode)
    {
        return -1 if $self->nextItem($Tier) < 0;  # NOT FOUND
    };
    
    return $self->currentItem($Tier);
}

# Next item with specific Parent ID (no ID -> no change)
sub nextParentID# ($Tier, $ParentIDcode) -> SpecificItem (or -1 if not found)
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $ParentIDcode = shift || return $self->currentItem($Tier);
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate ID
    while($self->nextItem($Tier) > 0)
    {
        return $self->currentItem($Tier) 
        if $self->currentParentID($Tier) eq $ParentIDcode;
    };
    
    return -1;  # NOT FOUND
}

# Previous item with specific Parent ID (no ID -> no change)
sub previousParentID# ($Tier, $ParentIDcode) -> SpecificItem (or -1 if not found)
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $ParentIDcode = shift || return $self->currentItem($Tier);
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate ID
    while($self->previousItem($Tier) > 0)
    {
        return $self->currentItem($Tier) 
        if $self->currentParentID($Tier) eq $ParentIDcode;
    };
    
    return $self->currentItem($Tier);
}

# Locate next value with grep: $VALUE =~ /$RegExpPattern/
sub grepnextValue	# ($Tier, $RegExpPattern) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Pattern = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate Value
    while($self->nextItem($Tier) >= 0)
    {
        last if $self->currentValue($Tier) =~ /$Pattern/;  # FOUND
    };

    return $self->currentItem($Tier);
}

# Locate next IDcode with grep: $ID =~ /$RegExpPattern/
sub grepnextID	# ($Tier, $RegExpPattern) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Pattern = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);

    # Locate Value
    while($self->nextItem($Tier) >= 0)
    {
        last if $self->currentIDcode($Tier) =~ /$Pattern/;  # FOUND
    };

    return $self->currentItem($Tier);
}

# Locate previous value with grep: $VALUE =~ /$RegExpPattern/
sub grepprevValue	# ($Tier, $RegExpPattern) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Pattern = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate Value
    while($self->previousItem($Tier) >= 0)
    {
        last if $self->currentValue($Tier) =~ /$Pattern/;  # FOUND
    };

    return $self->currentItem($Tier);
}


# Locate previous IDcode with grep: $ID =~ /$RegExpPattern/
sub grepprevID	# ($Tier, $RegExpPattern) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $Pattern = shift || "";
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    # Locate Value
    while($self->previousItem($Tier) >= 0)
    {
        last if $self->currentIDcode($Tier) =~ /$Pattern/;  # FOUND
    };

    return $self->currentItem($Tier);
}

#
# Determine whether the current item is inside a specified
# time window or item in another tier. 
#

# The current START is inside a given time interval [$begin, $end> or Tier.
# Note that the interval is shifted by -$self->{TOLERANCE}. If the
# size of the interval is less than $self->{TOLERANCE}, the interval is
# expanded by $self->{TOLERANCE}.
# If $begin is an existing Tier name, the current start and end times
# of that tier are used. If there is no $end, $end == $begin.
sub Startisininterval	# ($Tier, $begin [, $end]) -> currentItem or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift || 0;
    my $end = $begin;
    # Only give $end a value if it exists
    $end = shift(@_) if @_;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    my $CurrentStart = $self->currentStart($Tier);
    
    # A tier
    if($self->existsTier($begin))
    {
        my $TargetTier = $begin;
        $begin = $self->currentStart($TargetTier);
        $end = $self->currentEnd($TargetTier);
    };
    $self->existsTier($Tier);  # Reset Default
    
    # Return value
    my $InsideInterval = 0;
    # Inside time window
    my $Tolerance = $self->{TOLERANCE};
    if(($end - $begin) > $Tolerance)
    {
        $InsideInterval = ($CurrentStart > $begin - $Tolerance)
        && ($CurrentStart < $end - $Tolerance);
    }
    else # Not a window, but a time point
    {
        $InsideInterval = ($CurrentStart > $begin - $Tolerance)
        && ($CurrentStart < $end + $Tolerance);
    };   

    return $InsideInterval ? $self->currentItem($Tier) : -1;
}

# The current END is inside a given time interval <$begin, $end] or Tier.
# Note that the interval is shifted by +$self->{TOLERANCE}. If the
# size of the interval is less than $self->{TOLERANCE}, the interval is
# expanded by $self->{TOLERANCE}.
# If $begin is an existing Tier name, the current start and end times
# of that tier are used. If there is no $end, $end == $begin.
sub Endisininterval	# ($Tier, $begin [, $end]) -> currentItem or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift || 0;
    my $end = $begin;
    # Only give $end a value if it exists
    $end = shift if @_;
    
    # Does Tier actually exist?
    return -1 unless $self->existsTier($Tier);
    
    my $CurrentEnd = $self->currentEnd($Tier);
    
    # A tier
    if($self->existsTier($begin))
    {
        my $TargetTier = $begin;
        $begin = $self->currentStart($TargetTier);
        $end = $self->currentEnd($TargetTier);
    };
    $self->existsTier($Tier);  # Reset Default
    
    # Return value
    my $InsideInterval = 0;
    # Inside time window
    my $Tolerance = $self->{TOLERANCE};
    if(($end - $begin) > $Tolerance)
    {
        $InsideInterval = ($CurrentEnd > $begin + $Tolerance)
        && ($CurrentEnd < $end + $Tolerance);
    }
    else # Not a window, but a time point
    {
        $InsideInterval = ($CurrentEnd > $begin - $Tolerance)
        && ($CurrentEnd < $end + $Tolerance);
    };   
    
    return $InsideInterval ? $self->currentItem($Tier) : -1;
}

# The current START is aligned with a given time or Tier
# If $time is an existing Tier name, the current Start time
# of that tier is used.
# Uses Startisininterval.
sub Startisaligned	# ($Tier, $time) -> currentItem or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $time = shift || 0;
    
    my $TargetTier = $time;
    $time = $self->currentStart($TargetTier) if $self->existsTier($TargetTier);
    
    return $self->Startisininterval($Tier, $time, $time);
}

# The current END is aligned with a given time or Tier
# If $time is an existing Tier name, the current End time
# of that tier is used.
# Uses Endisininterval.
sub Endisaligned	# ($Tier, $time) -> currentItem or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $time = shift || 0;
    
    my $TargetTier = $time;
    $time = $self->currentEnd($TargetTier) if $self->existsTier($TargetTier);
    
    return $self->Endisininterval($Tier, $time, $time);
}

#
# Get the item in the parent tier that contains the current START.
# (the parent tier becomes the default tier)
sub parentItemStart   # (childTier, parentTier) -> parentIndex
{
    my $self = shift;
    my $childTier = shift || $self->{CURRENTTIER} || return -1;
    my $parentTier = shift || return -1;
    
    $self->presetItem($parentTier);
    
    until($self->nextItem($parentTier) < 0)
    {
        last unless $self->Startisininterval($childTier, $parentTier) < 0;
    };
    
    return $self->currentItem($parentTier);
}

#
# Get the item in the parent tier that contains the current END.
# (the parent tier becomes the default tier)
sub parentItemEnd   # (childTier, parentTier) -> parentIndex
{
    my $self = shift;
    my $childTier = shift || $self->{CURRENTTIER} || return -1;
    my $parentTier = shift || return -1;
    
    $self->presetItem($parentTier);
    
    until($self->nextItem($parentTier) < 0)
    {
        last unless $self->Endisininterval($childTier, $parentTier) < 0;
    };
    
    return $self->currentItem($parentTier);
}
    
# Locate the next/previous item with START or END
# within a given interval. If the end point of the 
# interval is 0, the duration is used.
# If the first argument after the Tier is an
# existing tier, the current Start and End values
# of that Tier are used as begin and end.

# Locate next item with start inside interval: 
# START >= $begin - $Tolerance && START < $end - $Tolerance
# $begin can be a Target Tiername.
sub nextStartininterval	# ($Tier, $begin, $end) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift;
    my $end = shift;
    
    # Locate Value
    until($self->nextItem($Tier) < 0)
    {
        last if $self->Startisininterval($Tier, $begin, $end) ;  # FOUND
    };
    
    return $self->currentItem($Tier);
}

# Locate next item with end inside interval: 
# END >= $begin - $Tolerance && END < $end - $Tolerance
# $begin can be a Target Tiername.
sub nextEndininterval	# ($Tier, $begin, $end) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift || 0;
    my $end = shift || $self->duration($Tier);
    
    # Locate Value
    until($self->nextItem($Tier) < 0)
    {
        last if $self->Endisininterval($Tier, $begin, $end);  # FOUND
    };
    
    return $self->currentItem($Tier);
}

# Locate previous item with start inside interval: 
# START > $begin + $Tolerance && START <= $end + $Tolerance
# $begin can be a Target Tiername.
sub previousStartininterval	# ($Tier, $begin, $end) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift;
    my $end = shift;
    
    # Locate Value
    until($self->previousItem($Tier) < 0)
    {
        last unless $self->Startisininterval($Tier, $begin, $end) < 0;  # FOUND
    };

    return $self->currentItem($Tier);
}

# Locate previous item with end inside interval: 
# END >= $begin - $Tolerance && END < $end - $Tolerance
# $begin can be a Target Tiername.
sub previousEndininterval	# ($Tier, $begin, $end) -> Index or -1
{
    my $self = shift;
    my $Tier = shift || $self->{CURRENTTIER} || return -1;
    my $begin = shift;
    my $end = shift;
    
    # Locate Value
    until($self->previousItem($Tier) < 0)
    {
        last unless $self->Endisininterval($Tier, $begin, $end) < 0;  # FOUND
    };
        
    return $self->currentItem($Tier);
}


#####################################################################
#
# Specific function needed for manipulating ID codes
#
#####################################################################
# 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;
};

#
# The ID code of the parent of an ID code.
# That is, chop of the trailing code block which is either
# Alphabetic or numeric (either with [-,.]).
# 
sub ParentIDcode	# ($IDcode) -> ParentIDcode (shortened)
{
    my $IDcode = shift || return "";
    
    my $ParentIDcode = "";
    
    # Remove trailing information
    $IDcode =~ s/[\_]+.*$//ig;
    
    # Special case for Syllable Parts
    if($IDcode =~ /^([FM][\d]+[A-Z]+[\d]+[A-Z]+[\d]+[A-Z]+[\d]+[S-Z\.\,\-][F]?)[OKC]$/i)   
    {
        $ParentIDcode = $1;
    }
    elsif($IDcode =~ /[A-Z\.\,\-]+$/i)
    {
        $ParentIDcode = $`;
    }
    elsif($IDcode =~ /[\d\.\,\-]+$/i)
    {
        $ParentIDcode = $`;
    };
    
    return $ParentIDcode;

}

#
# Fill in missing ID numbers with UNIQUE codes
sub InterpolateIDtier	# ($Tier) Complete the {ID}{$Tier}
{
    my $self = shift;
	my $Tier = shift || $self->{CURRENTTIER} || return 0;
	#
        # The ID codes to use
        my $PreviousIDcode = "";
        my $CurrentIDcode = "";
        my $NextIDcode = "";
        
	$self->presetItem($Tier);
	while($self->nextItem($Tier) > 0)
	{
            $PreviousIDcode = $CurrentIDcode;
            $CurrentIDcode = $self->currentID($Tier);
            $NextIDcode = "";
            my $CurrentItemPosition = $self->currentItem($Tier);
            unless($self->grepnextID($Tier, '\S') < 0)
            {
                $NextIDcode = $self->currentIDcode($Tier);
            };
            $self->setItem($Tier, $CurrentItemPosition);   # Reset the current position
            
		unless($CurrentIDcode)
		{
			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
                                $self->storeItem($Tier);
				while($self->locateID($Tier, /$NewIDcode/) >= 0)
				{
					IncreaseIDcode($NewIDcode);
				};
                                $self->restoreItem($Tier);   # Reset the current position
                                
			}
			# A little less simple
			elsif($PreviousIDcode =~ /\-([\d]+|[a-z]+)\-([\d]+|[a-z]+)$/i)
			{
				$NewIDcode = $`."-";
				my $Insert1 = $1;
				# Make sure the ID is unique
                                $self->storeItem($Tier);
				while($self->locateID($Tier, /$NewIDcode$Insert1/) >= 0)
				{
					++$Insert1;
				};
                                $self->restoreItem($Tier);   # Reset the current position
                                
				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
                                $self->storeItem($Tier);
				while($self->locateID($Tier, /$NewIDcode$Insert1/) >= 0)
				{
					++$Insert1;
				};
                                $self->restoreItem($Tier);   # Reset the current position
                                
				my $Insert2 = $Insert1 =~ /\d+$/ ? '1' : 'A';
				$NewIDcode .= "$Insert1-$Insert2";
			};

			$self->currentIDcode($Tier, $NewIDcode);
		};
	};
	return $Tier;
};

# Actually read a label file and contruct the label "ITEM"
sub ReadLabelFile   # ($FileName) Fills $self with tiers
{
    my $self = shift;
    my $FileName = shift;
    
    # Open file
    open(SOURCE, "<$FileName") || die "$FileName: $!\n";
    
    # Initialise Sentence ID code
    if($Filename =~ /[\.][^\.]*$/)
    {
        $self->{'SentenceIDcode'} = $`;
    };
    
    #
    # Fill all the TIERS
    #
    # From a TextGrid (label)
    my $Line;
    my $SentenceIDcode = $self->{'SentenceIDcode'};
    #
    # 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;
                    
                    #
                    my $StartTime = shift(@AllLines);
                    my $EndTime = shift(@AllLines);
                    $DURATION = $EndTime - $StartTime;
                    my $NumberOfItems = shift(@AllLines);
                    #
                    # Skip if tier already exists
                    next if $self->existsTier($Tier);
                    #
                    # Create a new (empty) Tier entry
                    $self->createTier($Tier);
                                                          
                    # Read all the items 
                    my $OldIDcode = "";
                    while(@AllLines && ($AllLines[0] !~ /\"IntervalTier\"/))
                    {
                        # Start
                        $Line = shift(@AllLines);
                        next unless $Line =~ /\S/;
                        $Line =~ /[\d\.]+/;
                        my $NewStart = $&;
                        
                        # End
                        $Line = shift(@AllLines);
                        $Line =~ /[\d\.]+/;
                        my $NewEnd = $&;
                        
                        # 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 _
                        my $NewIDcode = "";
                        
                        if($Line =~ /[\_]{2}/)
                        {
                            $NewIDcode = $';
                            $Line = $`;
                        };
                        # Store the actual value
                        my $NewValue = $Line;
                        
                        # Actually add the new item to the Tier
                        $self->pushItem($Tier, 
                        $NewValue, $NewIDcode, $NewStart, $NewEnd);                        
                    };
                };
            };
        };
    };
    #
    # Ready
    return $self;
}

#
# Fill Tiers TOP-DOWN
my @TierOrder = ('SENTENCE', 'TRANSLIT', 'WORDS', 'SYLLABLES', 'SYLLPARTS', 'PHONEMES');
sub FillIDcodes   
{
    my $self = shift;
    #
    my $TierNumber;
    for($TierNumber=1; $TierNumber < scalar(@TierOrder); ++$TierNumber)
    {
        $CurrentTier = $TierOrder[$TierNumber];
        $ParentTier = $TierOrder[$TierNumber-1];
        
        # Useless unless there are some ID's in the parent and none in the Current

        $self->presetItem($ParentTier);
        next if $self->grepnextID($ParentTier, '\S') < 0;
        $self->presetItem($CurrentTier);
        next unless $self->grepnextID($CurrentTier, '\S') < 0;

        #
        $self->presetItem($CurrentTier);  # Jump to -1
        until($self->nextItem($CurrentTier) < 0)
        {
            # The ID of an item is determined by its START
            die "NO parent item of $CurrentTier ", $self->currentItem($CurrentTier), " in $ParentTier: ", $self->currentItem($ParentTier), "\n" 
            if $self->parentItemStart($CurrentItem, $ParentTier) < 0;
            
            # Remember the current position
            $self->storeItem($CurrentTier);
            
            # Get the Previous ID and value
            $self->previousItem($CurrentTier);
            my $PreviousID = $self->currentIDcode($CurrentTier);
            my $PreviousValue = $self->currentValue($CurrentTier);
            
            # Get the Parent ID
            my $ParentID = $self->currentIDcode($ParentTier);
            
            # The previous item is INSIDE the current parent item, Increase ID
            if($self->Startisininterval($CurrentTier, $ParentTier) >= 0)
            {
                $self->restoreItem($CurrentTier);
                if($CurrentTier ne 'SYLLPARTS')
                {
                    $self->currentIDcode($CurrentTier, IncreaseIDcode($PreviousID));
                }
                else
                {
                    if($PreviousID =~ /O$/)
                    {
                        $self->currentIDcode($CurrentTier, $ParentID . 'K');
                    }
                    elsif($PreviousID =~ /K$/)
                    {
                        $self->currentIDcode($CurrentTier, $ParentID . 'C');
                    }
                    else
                    {
                        $self->currentIDcode($CurrentTier, $ParentID . '');
                    };
                    
                };
            }
            else	# The current item is the FIRST item
            {
                $self->restoreItem($CurrentTier);
                $NewIDcode = $ParentID;

                if($CurrentTier eq 'SYLLABLES')
                {
                    $NewIDcode .= 'S';
                    $NewIDcode .= 'F' if $PreviousValue =~ /\w/;
                }
                elsif($CurrentTier eq 'SYLLPARTS')
                {
                    if($self->currentValue($CurrentTier) !~ /[\@AEIOQIYiyaeou29\|\}]/)
                    {
                        $NewIDcode .= 'O';
                    }
                    else
                    {
                        $NewIDcode .= 'K';
                    };
                }
                else
                {
                    $NewIDcode .= $ParentID =~ /\d$/ ? 'A' : 1;
                };
                $self->currentIDcode($CurrentTier, $NewIDcode);
            };   
        };
    };
}

#
# Fill Tiers BOTTOM UP
#
# Fill CGN Words tier from Syllables (ONLY when label boundaries are correct)
sub FillCGNtier
{
    my $self = shift;
    #
    # Allready exists, don't change it
    return 0 if @{$self->{TIER}{CGN}};

    # Increase number of tiers
    ++$self->{'NUMBEROFTIERS'};
    
    # Collect Syllables
    my $SyllableLength = scalar(@{$self->{TIER}{SYLLABLES}});
    my $SyllableNumber = 0;
    my $WordNumber;
    for($WordNumber=0; $WordNumber < scalar(@{$self->{TIER}{WORDS}}); ++$WordNumber)
    {
    	   while($SyllableNumber < $SyllableLength
    	         && $self->{START}{SYLLABLES}[$SyllableNumber] <
    	   				$self->{START}{WORDS}[$WordNumber] - 0.0005)
    	   {
    	   		++$SyllableNumber;
    	   };
    	   my $CGNword = "";
    	   while($SyllableNumber < $SyllableLength
    	         && $self->{START}{SYLLABLES}[$SyllableNumber] <
    	   				$self->{END}{WORDS}[$WordNumber] - 0.0005)
    	   {
    	      $CGNword .= $self->{TIER}{SYLLABLES}[$SyllableNumber].'-';
    	   		++$SyllableNumber;
    	   };
    	   $CGNword =~ s/\-$//g;   # Remove the end-of-word hyphen

    	   # The CGN tier is a copy of the word tier    	
    	   $self->{START}{CGN}[$WordNumber] = $self->{START}{WORDS}[$WordNumber];
    	   $self->{END}{CGN}[$WordNumber]   = $self->{END}{WORDS}[$WordNumber];
    	   $self->{ID}{CGN}[$WordNumber]    = $self->{ID}{WORDS}[$WordNumber];
    	   $self->{TIER}{CGN}[$WordNumber]  =   $CGNword;
    };
    
}

sub InterpolateSyllPartsTier  # Top Down, mostly for the parts
{
    my $self = shift;
    #
    # Allready exists, don't change it
    unless(@{$self->{TIER}{SYLLPARTS}})
    {
        # Define relevant tiers
        $self->{TIER}{SYLLPARTS} = [];
        $self->{ID}{SYLLPARTS} = [];
        $self->{START}{SYLLPARTS} = [];
        $self->{END}{SYLLPARTS} = [];
	
        # Increase number of tiers
        ++$self->{'NUMBEROFTIERS'};
        
        # TOP-DOWN
        # Process all syllables
        my $Syllable;
        for($Syllable=0; $Syllable < scalar(@{$self->{TIER}{SYLLABLES}}); ++$Syllable)
        {
            # Get Syllable values
            my $SyllableText = $self->{TIER}{SYLLABLES}[$Syllable];
            my $SyllableIDcode = $self->{ID}{SYLLABLES}[$Syllable];
            my $SyllableStart = $self->{START}{SYLLABLES}[$Syllable];
            my $SyllableEnd = $self->{END}{SYLLABLES}[$Syllable];
            
            my $PrevSyllableText = $Syllable && $self->{ID}{SYLLABLES}[$Syllable-1] !~ /F$/ 
            ? $self->{TIER}{SYLLABLES}[$Syllable-1] : "";
            my $NextSyllableText = $self->{ID}{SYLLABLES}[$Syllable] !~ /F$/ 
            ? $self->{TIER}{SYLLABLES}[$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(@{$self->{START}{SYLLPARTS}}, $self->{END}{SYLLPARTS}[-1]);
                push(@{$self->{END}{SYLLPARTS}}, ($self->{START}{SYLLPARTS}[-1]+$DeltaT));	
                
                push(@{$self->{TIER}{SYLLPARTS}}, $Part);
                push(@{$self->{ID}{SYLLPARTS}}, $SyllableIDcode.(shift(@PartCodes))) if $SyllableIDcode;
            };
        };
    };
    
}

# Manage output of ID tiers
sub FoldedIDcodes       # (Tiernames...)   The Tiers whith ID codes folded in
{
    my $self = shift;
    # Tiers with folded ID coded
    @{$self->{FoldedIDcodes}} = @_;
}

sub IDcodeTiers # (Tiernames...)   The Tiers whith separate ID code tiers
{
    my $self = shift;
    # Tiers with folded ID coded
    @{$self->{IDcodeTiers}} = @_;
}

# Write a labelfile to the output
sub print       # (<OUTPUT>, Tiers...)   Print to filedescriptor <OUTPUT>
{
    my $self = shift;
    # Output must be an open file descriptor (e.g., STDOUT)
    my $OUTPUT = shift;
    # Get the names of the requested tiers
    my @PrintedTiers = @_;
    @PrintedTiers = ('WORDS', 'SYLLABLES', 'PHONEMES') unless @PrintedTiers;
    
    #
    # Make formatted (Praat) output
    #    
    my $i;
    open(OUTPUT, ">&$OUTPUT") || die ">&$OUTPUT: $!\n";
    
    print OUTPUT << "LABELEND";
File type = "ooTextFile short"
"TextGrid"

0
$self->{END}{$PrintedTiers[0]}[-1]
<exists>
LABELEND
    
    my $NumberOfTiers = 0;
    my $Tier;
    
    print OUTPUT "$self->{NUMBEROFTIERS}\n";
    
    foreach $Tier (reverse(@PrintedTiers))
    {
        # The tier with the values
        print OUTPUT "\"IntervalTier\"\n";
        print OUTPUT "\"$Tier\"\n";
        print OUTPUT "0\n";
        print OUTPUT "$self->{END}{$Tier}[-1]\n";
        print OUTPUT scalar(@{$self->{TIER}{$Tier}}), "\n";
        
        my $Interval;
        for($Interval=0; $Interval < scalar(@{$self->{TIER}{$Tier}}); ++$Interval)
        {
            print OUTPUT ${$self->{START}{$Tier}}[$Interval] 
            ? ${$self->{START}{$Tier}}[$Interval] : '0', "\n";
            print OUTPUT "${$self->{END}{$Tier}}[$Interval]\n";
            my $PrintText = "";
            # Fold the ID codes into the tier labels
            $PrintText .= ${$self->{TIER}{$Tier}}[$Interval];
            $PrintText .= '__' . ${$self->{ID}{$Tier}}[$Interval] if grep(/^$Tier$/, @{$self->{FoldedIDcodes}});                      
            $PrintText =~ s/([\'\"\`])/$1$1/g;
            print OUTPUT "\"$PrintText\"\n";
        };
        
        # Skip the ID code tier unless they are required
        next unless grep(/^$Tier$/, @{$self->{IDcodeTiers}});;
        
        # The tier with the IDcodes
        print OUTPUT "\"IntervalTier\"\n";
        print OUTPUT "\"${Tier}ID\"\n";
        print OUTPUT "0\n";
        print OUTPUT "$self->{END}{$Tier}[-1]\n";
        print OUTPUT scalar(@{$self->{ID}{$Tier}}), "\n";
        
        for($Interval=0; $Interval < scalar(@{$self->{ID}{$Tier}}); ++$Interval)
        {
            print OUTPUT ${$self->{START}{$Tier}}[$Interval] 
            ? ${$self->{START}{$Tier}}[$Interval] : '0', "\n";
            print OUTPUT "${$self->{END}{$Tier}}[$Interval]\n";
            print OUTPUT "\"${$self->{ID}{$Tier}}[$Interval]\"\n";
        };
    }; 
    
    return 1;
}

#
# The REALY difficult part: Realigning of the whole Label structure (BOTTOM-UP)
my @AlignmentHierarchy = ("SENTENCE", "TRANSLIT", "WORDS", "CGN",
                          "SYLLABLES", "SYLLPARTS", "PHONEMES");

sub realign    # (BottomTier)
{
    my $self = shift;
    # Output must be an open file descriptor (e.g., STDOUT)
    my $BottomTier = shift || 'PHONEMES';
    
    # Get the number of the Tier
    my $Order = 0;
    for($Order = $#AlignmentHierarchy; $Order > 0; --$Order)
    {
        last if $AlignmentHierarchy[$Order] eq $BottomTier;
    };
    
    #
    # Climb the tiers
    while($Order > 0)
    {
        my $SourceTier = $AlignmentHierarchy[$Order];
        my $TargetTier = $AlignmentHierarchy[$Order-1];
        
        # First handle the Copy Tiers
        if($SourceTier eq 'CGN' && $TargetTier eq 'WORDS')
        {
            my $Word;
            for($Word=0; $Word < scalar(@{$self->{TIER}{WORDS}}); ++$Word)
            {
                $self->{START}{WORDS}[$Word] = $self->{START}{CGN}[$Word];
            };
        }
        elsif($SourceTier eq 'TRANSLIT' && $TargetTier eq 'SENTENCE')
        {
            my $Sentence;
            for($Sentence=0; $Sentence < scalar(@{$self->{TIER}{SENTENCES}}); ++$Sentence)
            {
                $self->{START}{SENTENCES}[$Sentence] = $self->{START}{TRANSLIT}[$Sentence];
            };
        }
        elsif($SourceTier eq 'WORDS' && $TargetTier eq 'TRANSLIT')
        {
            my $Sentence;
            my $Word = 0;
            my $WordLength = scalar(@{$self->{TIER}{WORDS}});
            
            
            for($Sentence=0; $Sentence < scalar(@{$self->{TIER}{TRANSLIT}}); ++$Sentence)
            {
                my $Text = $self->{TIER}{TRANSLIT}[$Sentence];
                
                # Current sentence is a pause
                if($Text !~ /\w/)
                {
                    while($Word < $self->{TIER}{WORDS}[$Word] =~ /\w/)
                    {
                        ++$Word
                    };
                };
            };
        };
    };
        
        # Next tier
        --$Order;    
}

#
#
# Do not execute inside a require
unless(caller())
{
	# Define and initialize
    my @GlobFileList = @ARGV;
    my $FilePattern;
    my @praatScript = ();

    foreach $FilePattern (@GlobFileList)
    {
        # Get the real filenames (expand * and ?)
        my @FileList = glob("$FilePattern");
        my $FileName;

        # Handle All files
        foreach $FileName (@FileList)
        {
        	my $SpeakerID;
        	my $ItemID;
        	my $LabelFileName;
        	my $HomeDirectory;
        	
        	# Take apart the file path to get the relevant directories and ID numbers
        	# e.g., "./Speech/fm/F28G/F28G1FPA1VCVA_fm.aifc"
        	# -> $`=".", $1="Speech/fm", $2="F28G", $3="F28G1FPA1VCVA"
        	$FileName =~ m@/([\w]+/[\w]+)/([\w]+)/([^/]+)(\_[a-z]+)\.(wav|aifc|raw)$@i;
        	$HomeDirectory = $`;
        	$SpeechDirectory = $1;
        	$SpeakerID = $2;
        	$ItemID = $3;
        	$SpeechExtension = $4;
        	$SpeechFileType = $5;
        	
        	# Construct the filenames
        	# First, the name (and path) of the Labelfile
        	$LabelFileName = "$HomeDirectory/Labels/$SpeakerID/prephoneme/$ItemID.prephoneme";
        	
        	# Construct the relevant directory for storing the result
        	unless(-d "$HomeDirectory/Converted")
        	{
        		   mkdir("$HomeDirectory/Converted", 0744)
        	};
        	unless(-d "$HomeDirectory/Converted/$SpeakerID")
        	{
        		   mkdir("$HomeDirectory/Converted/$SpeakerID", 0744)
        	};
        	# The real target file
        	my $Targetfile = "$HomeDirectory/Converted/$SpeakerID/$ItemID$SpeechExtension.raw";
        	
        	# Read the labelfile and get the margins
        	my $LabelFile = new SentenceLabel;
        	$LabelFile->FoldedIDcodes('WORDS', 'SYLLABLES', 'PHONEMES');
        	$LabelFile->ReadLabelFile("$LabelFileName");
          # The end of the first word
        	$LabelFile->firstItem('WORDS');
        	my $X1 = $LabelFile->currentEnd('WORDS');
        	# The start of the last word
        	$LabelFile->lastItem('WORDS');
        	my $X2 = $LabelFile->currentStart('WORDS');
        	
        	# Construct praat script
        	push(@praatScript, "Read from file... $FileName\n");
        	push(@praatScript, "Formula... if x <= $X1 or x >= $X2 then 0 else self fi\n");
        	push(@praatScript, "Resample... $SampleRate 50\n");
        	push(@praatScript, "Write to raw sound file... $Targetfile $Encoding $BitWidth $Endian\n");
        	push(@praatScript, "select all\n");
        	push(@praatScript, "Remove\n");
        };
    };

    # Open praat and push script
    open(PRAAT, "|praat -") || die "Praat: $!\n";
    print PRAAT @praatScript;
    print PRAAT "Quit\n";
    close(PRAAT);
};

1; # Make require happy


