#!/usr/local/bin/perl

use strict;

# Ronald J Kimball, rjk-perl(at)tamias.net
# based on Sean Burke's convert_mpron.pl
# http://www.netadventure.net/~sburke/bounce.cgi/mpron/

use Getopt::Std;

use vars qw/$opt_i $opt_s $opt_l/;

getopts('isl') or die "Error.\n";

my $IAMBIC = $opt_i;
my $NOSPACES = $opt_s;
my $LOWERCASE = $opt_l;

#if (@ARGV and $ARGV[0] eq '-i') {
#    $IAMBIC = 1;
#    shift @ARGV;
#}

if (@ARGV != 2) {
  die "usage: $0 <input> <output>\n";
}

my($input, $output) = @ARGV;

my($word, $pron, $meter, $next_stress_flag);
my $Debug = 0;
# $/ = "\cm"; # may be necessary

my %vowel_remap = qw<
    eI     e
    aI     !
    Oi     ~
    AU     ^
    oU     o
    [@]    [
    (@)    (
>;

my $vowel_re = '(' . join('|', map quotemeta, keys %vowel_remap) . ')';

open(IN,  "<$input" ) or die "Can't open $input: $!\n";
open(OUT, ">$output") or die "Can't open $output: $!\n";

while (<IN>) {
  next if $NOSPACES and /_/;
   # skip words with spaces
   
  chomp;
  ($word, $pron) = split(' ', $_, 2);
  next unless $pron;
  
  next if $LOWERCASE and $word =~ /[A-Z]/ and $word ne 'I' and $word ne 'O';
   # skip words with uppercase letters (but allow I)

  $meter = '';
  $next_stress_flag = '0';
  foreach my $x ($pron =~ m<[',]|[aeiouAEIOUyY\@\&-]+>g) {
    if ($x eq ',') {
      $next_stress_flag = '2'; # secondary stress
      next;
    } elsif ($x eq "'") {
      $next_stress_flag = '1'; # primary stress
      next;
    }
    $meter .= $next_stress_flag;
    $next_stress_flag = '0';
  }

  next if $meter eq '';
   # skip words with no vowels in their pronunciation, such as 'shh'

  $meter =~ tr/0/2/ if $meter =~ m/^0+$/;
   # add stress to stressless words/phrases

  next if $IAMBIC and $meter =~ /1(?:..)*1/;
   # skip words which don't fit an iambic pattern

  $word =~ s,/.*,,;
   # remove part of speech indicator

  $pron =~ s/$vowel_re/$vowel_remap{$1}/go;
   # remap vowel sounds to single characters

  $pron =~ tr<', /_><>d;
   # remove stress marks, word separators, and the slashes

  sleep(0), printf "%10s %-20s %s\n", $meter, $word, $pron if $Debug;
  print OUT join("\t", $word, $meter, $pron), "\n";
  last if $Debug and $. > 1000;
}
close(OUT);
exit;
__END__