#!/usr/bin/perl
# chop_transcription.pl: Mark Hasegawa-Johnson, May 2004
# Illinois Speech and Language Engineering (ISLE group)
#
# Usage text (printed if called with no arguments):
$USAGE=<<ENDUSAGE;

CHOP_TRANSCRIPTION.PL: chop a set of transcriptions into the units 
  specified in an MLF file.  Useful for chopping word or phoneme
  transcriptions into utterance units, using utterance units given
  in the file in.mlf.

USAGE:
  chop_transcription.pl in.mlf in.scp

ARGUMENTS:

 in.mlf - master label file specifying chop units.
     Any line whose label section has no content outside [] is ignored.
     Other lines are counted, and output file is set to
     output_directory/input_file-num.wav
     where num is the transcription line number.

 in.scp - script file, with lines in the format of
     input_file  output_directory

     Input_file must have root filename corresponding to an
     entry in in.mlf.   
     Output_directory specifies the name of the directory
     to which chop units from input_file should be written

     
ENDUSAGE


####################################################################
# GLOBAL VARIABLES

# Math functions
sub abs { my($x)=shift; ($x>0) ? $x : -$x ; }
sub round { $_[0] =~ /([^\.]*)(.*)/; ($2 >= 0.5) ? $1+1 : $1; }
 
###################################################
# Subroutine to read MLF entry
#
# Syntax: $data = read_MLF_entry("filename", \*INPUTFILE);
#
# Returned value $data is an arrayref of arrayrefs
# $$tran[0][0] is first seg start time, in 100ns units
# $$tran[0][1] is end time, in 100ns units
# $$tran[0][2] is the sequence of labels at first time
# $$tran[0][3], if it exists, is the header of this line ---
#    this is different from other functions that use read_MLF_entry!!
#
sub read_MLF_entry {
  my($filename) = $_[0];
  my($fh) = $_[1];
  my(@tran) = ();
  
  # Read all continuous lines that begin with a char other than period
  for($l=<$fh>; $l =~ /^[^\.]/; $l=<$fh>) {
    chomp; chomp;

    # Option 0: line is in "header time time labels" format
    if ($l =~ /(\S+)\s+([\.\d]+)\s+([\.\d]+)\s+(.*)/ ) {
      push(@tran, [ $2*1e-7, $3*1e-7, $4, $1 ] );
    }
    # Option 1: line is in "time time labels" format
    elsif ($l=~/([\.\d]+)\s+([\.\d]+)\s+(.*)/ ) {
      push(@tran, [ $1*1e-7, $2*1e-7, $3, "" ] );
    }
    # Option 2: line contains any non-whitespace labels, but no times
    elsif ($l =~ /\S/) {
      push(@tran, [ 0, 0, $1, "" ] );
    }
  }
  return(\@tran);
}

################################################################
# Main program

if (@ARGV==0) { print STDERR $USAGE; exit; }

# Arguments
$MLF=$ARGV[0];
$SCP=$ARGV[1];
$CFG=$ARGV[2];

# Read in all lines from the INPUTFILE
open(MLF,$MLF) || die "Unable to read from $MLF: $!";
%IMLF=();
while (<MLF>) {
  # If this line starts a transcription, read it
  if (/\".*\/([^\/\.]+)[^\/]*\"/) {
    my($filename) = $1;
    # Get the root filename: any string of non-slashes
    #  terminated by a period, and completely lowercased
    $filename =~ /([^\/]+)\./;
    $rootfile=lc($1);
    $IMLF{$rootfile} = read_MLF_entry($filename,\*MLF);
  }
}

#######################
# Main loop: process each file/directory pair in the script
open(F,$SCP) || die "Unable to read from script file $SCP: $!\n";
$script = ''; while (<F>) { $script .= $_; }
close(F);
while($script =~ s/^\s*(\S+)\s+(\S+)//) {
  $filename = $1;
  $outdir = $2;

  # If outdir doesn't exist, try to make it
  unless ( -e $outdir ) { mkdir $outdir; }

  # Get the root filename: any string of non-slashes
  #  terminated by a period, and completely lowercased
  $filename =~ /([^\/]+)\./;
  $rootfile=lc($1);
  # Get rid of everything before the slashes and following the first dash
  $rootfile =~ s:.*/::;
  $rootfile =~ s/\-.*//;

  # If transcription doesn't exist, skip
  unless(exists $IMLF{$rootfile})  {
    print STDERR "Unable to find transcription for $rootfile\n";
  }
  else {
    # Filename: if there is an "sw0", replace with "sw"
    $filename =~ s/sw0/sw/;

    # If I can't open the file, skip
    unless(open(FID,$filename)) {
      print STDERR "Unable to read from $filename\n";
    }
    # Otherwise, read the transcription, then start chopping it
    else {
      @lines=();
      while ($line=<FID>) {
	chomp; chomp;

	# Remove anything non-numeric from the beginning of each line
	# $line =~ s/^\s*[^\d]\S*\s+//;
	
	# Find "header time time label" entry on each line
	$line =~ /(\S+)\s+([\.\d]+)\s+([\.\d]+)\s+(.*)/;
	# Enter these into @lines
	push(@lines, [$2, $3, $4, $1]);
      }
      close(FID);

      # Number of utterance units read for this file
      $num_read=0;
    
      foreach $arr (@{$IMLF{$rootfile}}) {
	# If this utterance matches [laughter-word], extract the word
	if($$arr[2] =~ /^\s*\[laughter-(.*)\]\s*$/) { $$arr[2] = $1; }

	# If this utterance matches [word1/word2], extract word2
	if($$arr[2] =~ /^\s*\[.*\/(.*)\]*$/) { $$arr[2] = $1; }

	# Now that those special cases have been taken care of,
	# Skip this utterance unit if label matches ^\s*\[.*\]\s*$
	unless($$arr[2] =~ /^\s*\[.*\]\s*$/) {
	  # Increment the number of lines read
	  $num_read++;

	  # Get the lines that lie completely between $$arr[0] and $$arr[1]
	  @outputlines = ();
	  foreach $line (@lines) {
	    if($$arr[0] <= $$line[0] && $$line[1] <= $$arr[1]) {
	      push(@outputlines, $line);
	    }
	  }

	  # Move it to its destination
	  $outfile=sprintf("%s/%s-%4.4d-word.text",$outdir,$rootfile,
			   $num_read);
	  #open(FID,">$outfile") || die "Unable to write to $outfile:", $!;
	  foreach $line (@outputlines) {
	   # print FID "$$line[3] $$line[0] $$line[1] $$line[2]\n";
	    # include $$line[3] --- a heuristic to get header
	    #   when header wasn't in the MLF	    
	    $$arr[3]=$$line[3];
	  }
	  #close(FID);
	  print STDERR "$rootfile, $filename, $outfile\n";


	  # Create the output trans file
	  $outfile=sprintf("%s/%s-%4.4d-trans.text",$outdir,$rootfile,
			   $num_read);
	  open(FID,">$outfile") || die "Unable to write to $outfile:", $!;
	  print FID "$$arr[3] $$arr[0] $$arr[1] $$arr[2]\n";
	  close(FID);
	}
      }
    }
  }

  
}

