#!/usr/bin/env perl
  
  # Oct 21, 2015 : Gaurav Kumar (Johns Hopkins University)
  # GNU General Public License, v3.0
  #
  # This script was modified under GPL and is being distributed with 
  # Kaldi. It requires the preference and rule files
  # (under LDC copyright) from LDC96L16. The main changes were
  # - Outdated usage of perl conventions updated @_ => $_ or @A
  # - This script no longer needs the preference and rule files to 
  #   be in the same directory as this script.
  # - Accepts tokens from <STDIN> instead of <>
  
  # --- Retained previous version information ----------------------------
  # spron.pl Version 0.1 Jan. 11 1995 
  # Written by Zhibiao Wu, LDC, wzb@unagi.cis.upenn.edu
  # This program needs the basic_rules file to run. The rules must be sorted 
  # in alphabetical order. The most specific rules should precede the more 
  # general ones. The conventions used in the basic rules are the same as 
  # regular expressions used in Perl.
  
  # Revised history: Feb. 10 1995
  
  # The file "preferences" (assumed to be in your current directory)
  # gives an "oracle" of correct pronunciations that override the
  # machine-generated ones.
  
  # slightly changed 97/09/05 robertm:
  #  - look for basic_rules and preferences in $PWD instead of ~wzb/...
  #  - use next to shortcut loop instead of if/else
  #  - added a bit of documentation, without really trying to decipher this thing
  # -----------------------------------------------------------------------
  
  use utf8;
  binmode(STDIN, ":utf8");
  binmode(STDOUT, ":utf8");
  
  $vfile = "";
  $preference_file = "";
  $rules_file = "";
  $print_input = 0;
  if ($#ARGV < 1) {
    # Print Usage
    print "Usage : local/spron.pl pref-file rules-file <v-file> <print-input>
  ";
    exit 1;
  } else {
    $preference_file = $ARGV[0];
    $rules_file = $ARGV[1];
    if ($#ARGV > 1) {
      $vfile = $ARGV[2];
    }
    if ($#ARGV > 2) {
      $print_input = 1;
    }
  }
  
  $rule_num = 0;
  $previous = "";
  if ($vfile ne "") {
    open(VF, $vfile) || die "Can't find file $vfile!
  ";
    while (<VF>) {
      chop;
      @A = split(//);
      if (($A[0] ne '#') && ($_ ne "")) {
        if (/(\S+)\s*->\s*(\S*)\s*:\s*(\S*)\s*__\s*(\S*)\s*(#?)/) {
          $head[$rule_num] = $1;
          $end[$rule_num] = $2;
          $pre[$rule_num] = $3;
          if ($4 =~ /#/) {
            $nex[$rule_num] = "";
            $some[$rule_num] = $4;
          } else {
            $nex[$rule_num] = $4;
            $some[$rule_num] = $5;
          }
          if ($previous ne substr($head[$rule_num],0,1)) {
            $first{$head[$rule_num]} = $rule_num;
            $last{$previous} = $rule_num - 1;
          }
          $previous = substr($head[$rule_num++],0,1);
        } else {
          print "Rule format error: Cannot parse $_
  ";
          exit(1);
        }
      }
    }
    $last{$previous} = $rule_num - 1;
  
    close(VF);
  }
  
  open(PF, $preference_file) || die "Can't read `preferences' file";
  binmode(PF, ":iso88591");
  while (<PF>) {
    chop;
    if ($_ ne "") {
      @A = split;
      $pron{$A[0]} = $A[1];
      $stre{$A[0]} = $A[2];
    }
  }
  
  $previous = "";
  $brule_num = 0;
  open(BF, $rules_file) || die "Can't read `basic_rules' file";
  binmode(BF, ":iso88591");
  while (<BF>) {
    chop;
    @A = split(//);
    if (($A[0] ne '#') && ($_ ne "")) {
      if (/(\S+)\s*->\s*(\S*)\s*:\s*(\S*)\s*__\s*(\S*)\s*(#?)/) {
        $bhead[$brule_num] = $1;
        $bend[$brule_num] = $2;
        $bpre[$brule_num] = $3;
        if ($4 =~ /#/) {
          $bnex[$brule_num] = "";
          $bsome[$brule_num] = $4;
        } else {
          $bnex[$brule_num] = $4;
          $bsome[$brule_num] = $5;
        }
        if ($previous ne substr($bhead[$brule_num],0,1)) {
          $bfirst{substr($bhead[$brule_num],0,1)} = $brule_num;
          $blast{$previous} = $brule_num - 1;
        }
        $previous = substr($bhead[$brule_num++],0,1);
      } else {
        print "Rule format error in file basic_rules: Cannot parse $_
  ";
        exit(1);
      }
    }
  }
  $blast{$previous} = $brule_num - 1;
  close(BF);
  
  if ($brule_num == 0) {
    print "No basic rules, Program exit!
  ";
    exit(1);
  }
  
  while(<STDIN>){
    next if ((/^#/) || (/^\s*$/) );
    chop;
    if ($print_input) {
      print $_, "\t";
    }
    if ($pron{$_}) {
      # print answer from preferences and skip to next word
      print "$pron{$_}\t$stre{$_}
  ";
      next;
    }
    $original = $_;
    tr/A-ZÁÉÍÓÚÏÜÑ/a-záéíóúïüñ/;
    $orig = "#" . $_ . "#";
  
    @l = ();
  
    push(@l,split("",$orig));
  
    @pron = &transfer(1);
  
    foreach (@pron) {
      $a = $_;
      y/aeiouáéíóú//cd;
      if ($_ eq "") {
        print "#No stressable vowel in $original
  ";
      } else {
        s/[aeiou]/0/go;
        s/[áéíóú]/1/go;
        if (!/1/) {
          if(length() == 1){
            s/\b./1/o;
          } elsif($l[$#l - 1] =~ /[aeiouns]/o){
            s/00\b/10/o;
          } else {
            s/0\b/1/o;
          }
        }
  
        $a =~ s/á/a/g;
        $a =~ s/é/e/g;
        $a =~ s/í/i/g;
        $a =~ s/ó/o/g;
        $a =~ s/ú/u/g;
  
        print "$a\t$_
  ";
      }
    }
  }
  
  sub transfer{
    local($_) = @_;
    local(@p) = ();
    local($s) = 0;
    local($over) = 0;
    local($i,$j,$k) = (0,0,0);
  
    if ($_ >= length($orig) - 1) {
      push(@p, "");
      return(@p);
    } else {
  
      if ($vfile ne "") {
        for ($i=   $first{substr($orig, $_, 1)}; 
          $i <= $last{substr($orig, $_, 1)} ; $i++) {
          if (&matchv($_,$i)) {
            $s = $_ + length($head[$i]);
            foreach $w (&transfer($s)) {
              push(@p, $end[$i] . $w);
              if ($some[$i] ne "") {
                $over = 0;
              } else {
                $over = 1;
              }
            }
          }
        }
      }
  
      if ($over == 0 ) {
        $i = $bfirst{substr($orig, $_, 1)}; 
        while (($i <= $blast{substr($orig, $_, 1)}) && ($over == 0)) {
          if (&matchb($_,$i)) {
            $over = 1;
            $s = $_ + length($bhead[$i]);
            foreach $w (&transfer($s)) {
              push(@p, $bend[$i] . $w);
            }
          }
          $i++;
        }
        if ($over == 0) {
          $s = $_ + 1;
          foreach $w (&transfer($s)) {
            push(@p, substr($orig,$_,1) . $w);
          }
        } 
      }
  
      return(@p);
    }
  }
  
  sub matchv {
    $h = $head[$_[1]];
    $p = $pre[$_[1]];
    $n = $nex[$_[1]];
  
    return(&match($_[0],$h,$p,$n));
  
  }
  
  sub matchb {
    $h = $bhead[$_[1]];
    $p = $bpre[$_[1]];
    $n = $bnex[$_[1]];
  
    return(&match($_[0],$h,$p,$n));
  
  }
  
  sub match {
  
    if (substr($orig, $_[0], length($_[1])) eq $_[1]) {
      return ( &match_n($_[0] + length($_[1]) - 1, $_[3]) && 
        &match_p($_[0], $_[2])); 
    } else {
      return (0);
    }
  }
  
  sub match_p {
    local($a) = $_[0];
    local($b) = $_[1];
    local($_);
  
    if ($b eq "" ) {
      return (1);
    } else {
      $_ = substr($orig, 0, $a) . "!";  
      if (/($b)!/) {
        return(1);
      } else {
        return(0);
      }
    }
  }
  
  sub match_n {
    local($a) = $_[0];
    local($b) = $_[1];
    local($_);
  
    if ($b eq "" ) {
      return (1);
    } else {
      $_ = "!" . substr($orig, $a + 1, length($orig) - $a - 1);  
      if (/!($b)/) {
        return(1);
      } else {
        return(0);
      }
    }
  }