#!/usr/bin/perl -w

use strict;

use base qw(XML::SAX::Base);
#use Unicode::String qw(utf8 latin1);


# convert LEXIN phones to modified SAMPA phones
# SAMPA: http://www.phon.ucl.ac.uk/home/sampa/swedish.htm
# my modified HTK SAMPA: http://www.cs.chalmers.se/~bringert/darcs/atkswe/transcription.txt
# SAMPA   HTK
# }:      u0:
# 2:      o2:
# 2       o2
# {:	  E3:
# 9:	  o3:
# { 	  E3
# 9	  o3
# @	  eh

# when there are several phones which are prefixes
# of a pronunciation, the longest match is used.
my $phone_trans = 
    latin1keys ({
    ({
     # short plosives
     'p'  => 'p',
     'b'  => 'b',
     't'  => 't',
     'd'  => 'd',
     'k'  => 'k',
     'g'  => 'g',
     # long plosives
     'p:' => 'p',
     'b:' => 'b',
     't:' => 't',
     'd:' => 'd',
     'k:' => 'k',
     'g:' => 'g',
     # short fricatives
     'f'  => 'f',
     'v'  => 'v',
     's'  => 's',
     '$'  => 'S',
     'h'  => 'h',
     'c'  => 'C',
     # long fricatives
     'f:' => 'f',
     'v:' => 'v',
     's:' => 's',
     '$:' => 'S',
     # short sonorant consonants
     'm'  => 'm',
     'n'  => 'n',
     '@'  => 'N',
     'r'  => 'r',
     'l'  => 'l',
     'j'  => 'j',
     # long sonorant consonants
     'm:' => 'm',
     'n:' => 'n',
     '@:' => 'N',
     'r:' => 'r',
     'l:' => 'l',
     'j:' => 'j',
     # short retroflex consonants
     'r+t' => 'rt',
     'r+d' => 'rd',
     'r+n' => 'rn',
     'r+s' => 'rs',
     'r+l' => 'rl',
     # long retroflex consonants
     'r+t:' => 'rt',
     'r+d:' => 'rd',
     'r+n:' => 'rn',
     'r+s:' => 'rs',
     'r+l:' => 'rl',
     # unstressed short vowels
     'i'  => 'I',
     'e'  => 'e',
     'ä'  => 'E',
     'y'  => 'Y',
     'u'  => 'u0',
     'ö'  => 'o2',
     'o'  => 'U',
     'å'  => 'O',
     'a'  => 'a',
     # unstressed long vowels
     'i:' => 'i:',
     'e:' => 'e:',
     'ä:' => 'E:',
     'y:' => 'y:',
     'u:' => 'u0:',
     'ö:' => 'o2:',
     'o:' => 'u:',
     'å:' => 'o:',
     'a:' => 'A:',
     # stressed short vowels
     'I'  => 'I',
     'E'  => 'e',
     'Ä'  => 'E',
     'Y'  => 'Y',
     'U'  => 'u0',
     'Ö'  => 'o2',
     'O'  => 'U',
     'Å'  => 'O',
     'A'  => 'a',
     # stressed long vowels
     'I:' => 'i:',
     'E:' => 'e:',
     'Ä:' => 'E:',
     'Y:' => 'y:',
     'U:' => 'u0:',
     'Ö:' => 'o2:',
     'O:' => 'u:',
     'Å:' => 'o:',
     'A:' => 'A:',

     # Special stuff
     # FIXME: what should these be in SAMPA?

     # foreign sounds
     'w'  => 'v',
     'z'  => 's',
     # diphtongs
     'a+o' => 'a U', # underground
     'A+O' => 'a U', 
     'a+u' => 'a u0', # rauk 
     'A+U' => 'a u0',
     'o+u' => 'U u0', # go
     'O+U' => 'U u0',
     'e+u' => 'e u0', # europa
     'E+U' => 'e u0',
     'å+u' => 'O u0', # trenchcoat
     'Å+U' => 'O u0',
     # tone mark
     '2'  => '',
     # non-retroflex consonant clusters, with short 2nd consonant
     'rt' => 'r t',
     'rd' => 'r d',
     'rn' => 'r n',
     'rs' => 'r s',
     'rl' => 'r l',
     # non-retroflex consonant clusters, with long 2nd consonant
     'rt:' => 'r t',
     'rd:' => 'r d',
     'rn:' => 'r n',
     'rs:' => 'r s',
     'rl:' => 'r l',
     });

my $max_phone_length = 0;
foreach (keys %$phone_trans) {
    my $l = length($_);
    if ($l > $max_phone_length) {
	$max_phone_length = $l; 
    }
}

sub latin1keys {
    my $h = {};
    foreach (keys(%{$_[0]})) {
	my $k = utf8($_)->latin1;
	$h->{$k} = $_[0]->{$_};
   }
    return $h;
}

sub add_word {
    my ($x,$y) = @_;
    if ($x ne '') {
	$x .= ' ';
    }
    return $x . $y;
}

sub mk_pron {
    my $p = shift;
    my $n = length($p);
    my $q = "";

    STEP: for (my $i = 0; $i < $n; ) {
	my $l = $max_phone_length;
	for (; $l > 0; $l--) {
	    my $t = $phone_trans->{substr($p,$i,$l)};
	    if (defined $t) {
		$q = add_word($q, $t);
		$i += $l;
		next STEP;
	    }
	}
	# phone not found
	my $x = substr($p,$i,1);
	print STDERR "htk_pron: In '$p': unknown phone: '$x'\n";
	return undef;
    }

    return $q;
}

sub print_pair {
    my ($form, $pron) = @_;
    my $p = mk_pron($pron);
    # don't print pronunciations with unknown phones
    if (defined $p) {
        my $s = sprintf("%-35s %s\n", $form, $p);
        print $s;
    }
}


while (<>) {
    my ($w,$p) = split;
    chomp $p;
    print_pair($w,$p);
}
