#!/usr/bin/perl

############################################
# text2phone:
#
# David HAUBENSACK, haubensack@cea.fr, 1996
# d'apres un script de Alistair CONKIE

require 5.001;
use FileHandle;

############################################
# program principal:
#
# faire "text2phone -h" pour avoir une aide.

# debut de configuration:

#$olabase = $ENV{"II_OLA_BASE"};
#$text2phonebase = $ENV{"II_OLA_BASE"};

# $olabase = "fr1";
$olabase = "/home/jmv/install/mbrola-fr/fr";

# $text2phonebase = "base";
$text2phonebase = "/home/jmv/install/tts-French/base";

# $mbrola_cmd = "| mbrola $olabase - -.au | audioplay";
$mbrola_cmd = "| mbrola $olabase - -.au > $ARGV[0]-$$.au";

$speed_ratio = 1.0;
$tonal_ratio = 1.0;

# fin de configuration.

$debug = 0;
$toprint = 0;
$viewrules = 0;
$doprosody = 1;

while( $opt = $ARGV[0] )
{
	last if( !($opt =~ /^-/) );
	if( $opt =~ /^-h/ )
	{
		usage();
		exit( 0 );
	}
	elsif( $opt =~ /^-d/ )
	{
		$debug = 1;
	}
	elsif( $opt =~ /^-D/ )
	{
		$debug = 2;
	}
	elsif( $opt =~ /^-p/ )
	{
		$toprint = 1;
	}
	elsif( $opt =~ /^-r/ )
	{
		$viewrules = 1;
	}
	elsif( $opt =~ /^-n/ )
	{
		$doprosody = 0;
	}
	elsif( $opt =~ /^-s/ )
	{
		$speed_ratio = $ARGV[0];
		$speed_ratio =~ s/^-s//;
	}
	elsif( $opt =~ /^-t/ )
	{
		$tonal_ratio = $ARGV[0];
		$tonal_ratio =~ s/^-t//;
	}
	shift @ARGV;
}

read_rules( $text2phonebase );
initialisation();

if( $viewrules )
{
	print_rules();
	exit( 0 );
}

if( ! $toprint )
{
	open( MBROLA, $mbrola_cmd );
	MBROLA->autoflush( 1 );
}
		
while( $phrase = <> )
{
	chop( $phrase );
	
	if( $phrase eq "" )
	{
		read_rules( $text2phonebase );
		initialisation();
	}

	print "------------------\n" if( $debug );
	
	$phrasefiltered = filter_sentence( $phrase );
	
	$resultat = translator( $phrasefiltered );
	
	if( $toprint )
	{
		print $resultat;
	}
	else
	{
		if( $debug )
		{
			print "------------------\n";
			print $resultat;
		}
		
		# enleve les commentaires et envoie a MBROLA:
		$resultat =~ s/\s*;.*//g;
		print MBROLA $resultat;
	}
}

close( MBROLA ) if( ! $toprint );


############################################
# usage:

sub usage
{
	print "text2phone -dhprn -sSPEED -tTONAL [file1 file2...]\n";
	print " -h: aide.\n";
	print " -d: mode debug léger.\n";
	print " -D: mode debug lourd.\n";
	print " -p: sortie sur stdout (defaut vers MBROLA).\n";
	print " -r: liste les règles.\n";
	print " -n: pas de prosodie.\n";
	print " -s: fixe le ratio de vitesse à SPEED (defaut=1.0).\n";
	print " -t: fixe le ratio de tonalité à TONAL (defaut=1.0).\n";
}

############################################
# initialisation:

sub initialisation
{
	# frequence offset:
	$f_offset = -8;
	
	# frequence au debut d'une phrase:
	$f_start = 120;
	$f_stat += $f_offset;
	$f_stat *= $tonal_ratio;
	
	# frequence pres de la fin d'une phrase:
	$f_nearend = 85;
	$f_nearend += $f_offset;
	$f_nearend *= $tonal_ratio;

	# frequence a la fin d'une phrase:
	$f_end = 70;
	$f_end += $f_offset;
	$f_end *= $tonal_ratio;

	# frequence a la fin d'une phrase interrogative:
	$f_intero = 175;
	$f_intero += $f_offset;
	$f_intero *= $tonal_ratio;

	# frequence pres de la fin d'une phrase interrogative:
	$f_nearintero = 130;
	$f_nearintero += $f_offset;
	$f_nearintero *= $tonal_ratio;

	# frequence au debut d'une pause courte:
	$f_startpause = 111;
	$f_startpause += $f_offset;
	$f_startpause *= $tonal_ratio;
	
	# frequence a la fin d'une pause courte:
	$f_endpause = 98;
	$f_endpause += $f_offset;
	$f_endpause *= $tonal_ratio;
	
	# frequence au debut d'une liaison:
	$f_startlegato = 108;
	$f_startlegato += $f_offset;
	$f_startlegato *= $tonal_ratio;
	
	# frequence a la fin d'une liaison:
	$f_endlegato = 102;
	$f_endlegato += $f_offset;
	$f_endlegato *= $tonal_ratio;
	
	
	# vitesse (%) normal:
	$speed_normal = 100;
	
	# vitesse (%) apres une pause (.):
	$speed_startpause = 80;
	
	# vitesse (%) avant une pause:
	$speed_endpause = 130;
	
	# vitesse (%) apres une pause courte (_):
	$speed_startpause = 90;
	
	# vitesse (%) apres une liaison (&):
	$speed_startlegato = 93;
	
	# augmentation de vitesse a chaque phoneme:
	$incspeed = 5;
	

	# durees moyennes des phonemes:
	%durations = 
	(
		'<'		,	150,	# pause normale montante (ponctuation)
		# jmv '>'		,	150,	# pause normale descendante (ponctuation)
		'>'		,	700,	# pause normale descendante (ponctuation)
		':'		,	14,		# pause forcee entre 2 mots
		'&'		,	0,		# pause nul entre deux mots lies 
		'_'		,	14,		# pause courte entre deux mots non-lies
		'p'		,	96,
		'b'		,	74,
		't'		,	88,
		'd'		,	68,
		'k'		,	80,
		'g'		,	55,
		'f'		,	122,
		'v'		,	78,
		'S'		,	119,
		'Z'		,	79,
		's'		,	123,
		'z'		,	86,
		'm'		,	76,
		'n'		,	63,
		'N'		,	72,
		'j'		,	61,
		'w'		,	65,
		'R'		,	53,
		'l'		,	49,
		'H'		,	58,
		'i'		,	78,
		'e'		,	85,
		'E'		,	81,
		'a'		,	83,
		'O'		,	94,
		'o'		,	83,
		'u'		,	86,
		'y'		,	74,
		'2'		,	106,
		'9'		,	99,
		'@'		,	75,
		'o~'	,	104,
		'a~'	,	111,
		'e~'	,	95,
		'U~'	,	102
	);
	
	$sampa = "p b t d k g f v S Z s z m n N j w R l H i e E a O o u y 2 9 @ o~ a~ e~ U~";
	$sampa_c = "p b t d k g f v S Z s z m n N j w R l H";
	$sampa_v = "i e E a O o u y 2 9 @ o~ a~ e~ U~";
	
	$voyelles = $class{'V'};
	$consonnes = $class{'C'};
	$ponctuations = $class{'P'};
	$chiffres = $class{'N'};

	@nombres = (
		"",
		" un",
		" deux",
		" trois",
		" quatre",
		" cinq",
		" six",
		" sept",
		" huit",
		" neuf",
		" dix",
		" onze",
		" douze",
		" treize",
		" quatorze",
		" quinze",
		" seize",
		" disept",
		" dizuit",
		" dizneuf",
	);

	@dizaines = (
		"",
		"",
		" vingt",
		" trente",
		" quarante",
		" cinquante",
		" soixante",
		" soixante",
		" quatrevingt",
		" quatrevingt",
	);
	
	@puissances = (
		"",
		" mille",
		" million",
		" milliard",
	);
	
	%lettres = (
		"a", "a",
		"b", "bé",
		"c", "sé",
		"d", "dé",
		"e", "oeu",
		"f", "èf",
		"g", "jé",
		"h", "ach",
		"i", "i",
		"j", "ji",
		"k", "ka",
		"l", "èl",
		"m", "èm",
		"n", "èn",
		"o", "o",
		"p", "pé",
		"q", "ku",
		"r", "èr",
		"s", "ès",
		"t", "té",
		"u", "u",
		"v", "vé",
		"w", "doublevé",
		"x", "ix",
		"y", "igrèk",
		"z", "zèd",
	)
}

############################################
# read rules:
#
# load phonetic rules from a file into @rulebase

sub read_rules
{
	my $filename = shift;
	my $n = 0;
	
	@rulebase = ();
	print "RULES\n" if( $debug );
	
	unless( open( RULES, "$filename" ) )
	{
		print STDERR "Impossible d'ouvrir la base de règles: $!\n";
		return(1);
	}

	# reading rules flag:
	$reading_rules = 0;
	
	while( $in = <RULES> )
	{
		# supprime la fin de ligne:
		chop;
		
		# supprime les commentaires:
		$in =~ s/\#.*//;	
		
		# evite les lignes blanches:
		if( $in =~ /^\s*$/ )
		{
			next;
		}
		
		if( $in =~ /^RULE[S]?$/ )
		{
			# keyword RULE:
			# (debut des regles)
			
			if( $reading_rules == 0 )
			{
				$reading_rules = 1;
				next;
			}
			else
			{
				print STDERR "Trop de RULES\n";
				return(1);
			}
		}
		elsif( $in =~ /^CLASS/ )
		{
			# keyword CLASS:
			# (classes de lettres)
			
			if( $reading_rules == 0 )
			{
				@class = split( ' ', $in );
				shift( @class );
				$classkey = shift( @class );
				$class{$classkey} = join( ' ', @class );
				next;
			}
			else
			{
				print STDERR "CLASS seulement avant RULES\n";
				return(1);
			}
		}
		elsif( $reading_rules == 1 )
		{
			# lecture des regles:
			
			# remplace les classes de lettres par leur liste:
			
			$again = 1;
			
			while( $again )
			{
				$again = 0;
				
				foreach $celem (keys(%class))
				{
					$again += ($in =~ s/$celem(.*)\[\[/$class{$celem}$1\[\[/g);
					$again += ($in =~
						s/\]\](.*)$celem(.*)\-\>/\]\]$1$class{$celem}$2\-\>/g);
				}
			}
			
			@bits = read_rule( $in );
			$n++;
			
			# using $headletter cuts down the rules to be searched
			# (extrait la premiere lettre de la target):
			
			if( $bits[0] ne '' )
			{
				$headletter = $bits[0];
				$headletter =~ s/^(.).*/$1/;
			}
			else
			{
				$headletter = '';
			}
			
			# ajoute la clef @bits a la liste des regles
			# commencant par $headletter:
			
			push( @{$rulebase{$headletter}}, [ @bits ] );
		}
	}
	
	$reading_rules = 0;
	close(RULES);
}

############################################
# read_rule:
#
# load one rule

sub read_rule
{
	my $rule = $_[0];
	my $lc;
	my $targ;
	my $rc;
	my $out;

	if( $rule =~ /^\s*((\S+)\s+)?\[\[ (.*) \]\]\s+((\S+)\s+)?\-\>(.*)/ )
	{
		$lc = $2;
		$targ = $3;
		$rc = $5;
		$out = join( ' ', split( ' ', $6 ) );

		return( ($targ,$lc,$rc,$out) );
	}
}

############################################
# print all rules:

sub print_rules
{
	my $targ;
	my $lc;
	my $rc;
	my $out;
	
	foreach $hl ( sort( keys( %rulebase ) ) )
	{
		print "headletter [$hl]\n";
		
		foreach $key (@{$rulebase{$hl}})
		{
			($targ,$lc,$rc,$out) = @{$key};
			printf "  %s / [%s] / %s = %s\n", $lc, $targ, $rc, $out;
		}
	}
}

############################################
# filter_sentence:
#
# prepare a sentence for translation

sub filter_sentence
{
	my $phrase = shift;
	my $tmp = "";
	
	# minuscules:
	$phrase =~ tr/A-Z/a-z/;
	
	# transforme les faux accents:
	$phrase =~ s/e\'/é/g;
	$phrase =~ s/a\`/à/g;
	$phrase =~ s/e\`/è/g;
	$phrase =~ s/u\`/ù/g;
	$phrase =~ s/a\^/â/g;
	$phrase =~ s/e\^/ê/g;
	$phrase =~ s/i\^/î/g;
	$phrase =~ s/o\^/ô/g;
	$phrase =~ s/u\^/û/g;
	$phrase =~ s/i\"/ï/g;
	$phrase =~ s/o\"/ö/g;
	$phrase =~ s/u\"/ü/g;
	$phrase =~ s/c,([a-z])/ç$1/g;
	
	# transforme temporairement les apostrophes (eventuellement
	# suivies d'un espace) en A:
	$phrase =~ s/\'(\s)*/A/g;

	# traduit les lettres isolees:
	
	$reste = $phrase;
	$phrase = "";
	
	while( $reste =~ /(^|.*(\W|\d))([a-z])((\W|\d).*|$)/ )
	{
		$tmp = $lettres{ $3 };
		$phrase .= $1 . $tmp;
		$reste = $4;
	}

	$phrase .= $reste;
	
	# recupere les apostrophes:
	$phrase =~ s/A/\'/g;

	# traduit les virgules decimales:
	$phrase =~ s/(\d)\.(\d)/$1 virgule $2/g;

	# rajoute un espace entre un chiffre et une lettre:
	$phrase =~ s/(\d)([a-z])/$1 $2/g;
	
	print "->[$phrase]\n" if( $debug );

	# traduit les nombres:
	while( $phrase=~ /(\D*)(\d+)(.*)/ )
	{
		$tmp = translate_number( $2 );
		print "$2 = $tmp\n" if( $debug );
		$phrase = $1 . $tmp . $3;
	}

	# supprime les traits d'union:
	$phrase =~ s/\-/ /g;
	
	# enleve les espaces autour des ponctuations:
	$phrase =~ s/\s*($ponctuations)\s*/$1/g;
	
	# supprime les doubles espaces et les change en _:
	$phrase =~ s/\s+/_/g;
	
	# change une lettre/espace final en un point:
	$phrase =~ s/(\w)$/$1./;
	
	# change une lettre/espace final en un point:
	$phrase =~ s/_$/./;
	
	print "->[$phrase]\n" if( $debug );

	$phrase;
}

############################################
# translator:
#
# translate a sentence into MBROLA input.

sub translator
{
	my $input = shift;		# mot a traduire
	my $k = $input;
	my $output = "";
	my $resultat = "";

	( $k, $output ) = phonetize( $input );
	
	$output2 = make_legato( $output );
	
	if( $doprosody )
	{
		$resultat = simple_prosody( $output2 );
	}
	else
	{
		$resultat = no_prosody( $output2 );
	}
	
	if( $debug )
	{
		print "------------------\n";
		printf "[$k]\n";
		printf "->[$output]\n";
		printf "->[$output2]\n";
	}

	$resultat;
}

############################################
# phonetize:
#
# traduce a sentence into phonems

sub phonetize
{
	my $right = shift;	# contient le reste du mot a traduire

	my $key;			# regle/clef courante
	my $w;				# contient le decoupage du mot en cibles
	my $t;				# resultat
	
	my $lc;				# clef: membre gauche
	my $targ;			# clef: membre central/cible
	my $rc;				# clef: membre droit
	my $out;			# clef: phoneme en sortie
	
	my $left = '';		# contient la partie du mot deja resolue

	print "------------------\n" if( $debug == 2 );
	
	WHLOOP:	
	while( $right ne '' )
	{
		# recupere la premiere lettre du mot:
		
		$hl = $right;
		$hl =~ s/^(.).*/$1/;
		
		# on examine les differentes regles commencant par $hl:
		
		foreach $key (@{$rulebase{$hl}})
		{
			($targ,$lc,$rc,$out) = @{$key};
			
			if( ($left =~ /$lc$/) && ($right =~ /^\Q$targ\E($rc.*)/) )
			{
				$left .= $targ;
				$right = $1;
				$w = "$w|$targ";
				$t = "$t $out";
				print "examine ($left/$right) [$targ] $lc:$rc -> $out\n"
					if( $debug == 2 );
				next WHLOOP;
			}
		}
		
		# on n'a pas trouve de regle correspondante:
		
		if( $right =~/^(.)(.*)/ )
		{
			$left .= $1;
			$right = $2;
			$w = "$w|$1";
			$t = "$t <error>";
			next WHLOOP;
		}
	}
	
	$t =~ s/\s+/ /g;
	$t =~ s/^ //g;
	$t =~ s/ $//g;
	$w =~ s/^\|//g;
	
	return( ($w,$t) );
}

############################################
# make_legato:
#
# change _ into & when a legato can be done.

sub make_legato
{
	my $input = shift;
	my $output = "";
	my @sequence = ();
	my $cur = "";
	my $prec = "";
	my $cur_v = 2;
	my $prec_v = 2;
	my $ante_v = 2;
	
	@sequence = split( ' ', $input );

	foreach $cur ( @sequence )
	{
		$cur_v = (($sampa_v =~ /$cur/) != 0);
		
		if( $prec eq "_" )
		{
			if( $cur_v + $ante_v != 1 )
			{
				$output .= " _";
			}
			else
			{
				$output .= " &";
			}
		}
		else
		{
			$output .= " $prec"; 
		}
		
		$prec = $cur;
		$ante_v = $prec_v;
		$prec_v = $cur_v;
	}

	$output .= " $prec";
	
	$output =~ s/\s+/ /g;
	$output =~ s/^ //g;
	$output =~ s/ $//g;
	
	# retransforme les : en _
	$output =~ s/:/_/g;
	
	$output;
}

############################################
# simple_prosody:
#
# generate a simple prosody
# (durations+frequencies):

sub simple_prosody
{
	my $input = shift;
	
	my @sequence = ();
	my $prec = "";
	my $pho = "";
	my $suiv = "";
	my $resultat = "";
	
	@sequence = split( ' ', $input );

	$resultat .= "_ 200 0 $f_start\n";

	$speed = $speed_startpause;
	
	$f_suiv = 0;
	
	foreach $suiv ( @sequence )
	{
		$resultat .= calc_duree( $prec, $pho, $suiv ) if( $pho ne "" );
		$prec = $pho;
		$pho = $suiv;
	}

	$resultat .= calc_duree( $prec, $pho, "" );
	
	$resultat .= "_ 200 0 $f_end\n";
	$resultat .= "#\n";
	
	$resultat;
}

############################################
# calc_duree:
#
# compute the duration of one phonem,
# considering the next one

sub calc_duree
{
	my $prec = shift;
	my $pho = shift;
	my $suiv = shift;
	
	my $resultat = "";
	my $notend = ($sampa =~ /$suiv/) || ($suiv eq "&");
	
	if( $suiv eq "&" )
	{
		$freq = $f_endlegato;
	}
	
	if( $suiv eq "<" )
	{
		$freq = $f_nearintero;
	}
	
	if( $suiv eq ">" )
	{
		$freq = $f_nearend;
	}
	
	if( $prec eq "&" )
	{
		$freq = $f_startlegato;
	}
	
	if( $pho ne "" )
	{
		$duree = 90;
		if( exists( $durations{$pho} ) )
		{
			$duree = $durations{$pho};
		}
		
		$speed = $speed_endpause if( ! $notend );
		
		$duree *= $speed*$speed_ratio/100;
		$duree = int( $duree );
			
		if( $pho eq "<" )
		{
			$resultat .= "_ $duree 0 $f_intero ; sp=$speed\n";
			$freq = $f_start;
			$speed = $speed_startpause;
		}
		elsif( $pho eq ">" )
		{
			$resultat .= "_ $duree 0 $f_end ; sp=$speed\n";
			$freq = $f_start;
			$speed = $speed_startpause;
		}
		elsif( $pho eq "_" )
		{
			$resultat .= "_ $duree 0 $f_endpause; sp=$speed\n";
			$freq = $f_startpause;
			$speed = $speed_startpause;
		}
		elsif( $pho eq "&" )
		{
			$speed = $speed_startlegato;
		}
		else
		{
			if( $freq == 0 )
			{
				$resultat .= "$pho $duree ; sp=$speed\n";
			}
			else
			{
				$resultat .= "$pho $duree 0 $freq ; sp=$speed\n";
			}
			
			$freq = 0;
			
			if( $speed < $speed_normal )
			{
				$speed += $incspeed;
 			}
 			else
 			{
 				$speed = $speed_normal;
 			}
		}
	}
	
	$resultat;
}

############################################
# no_prosody:
#
# generate no prosody

sub no_prosody
{
	my $input = shift;
	
	my @sequence = ();
	my $pho = "";
	my $resultat = "";
	
	@sequence = split( ' ', $input );

	$resultat .= "_ 200 0 102\n";

	foreach $pho ( @sequence )
	{
		next if( $pho eq "&" );
		$pho = "_" if( "<>_" =~ /$pho/ );
		$resultat .= "$pho 90\n";
	}

	$resultat .= "_ 200 0 102\n";
	$resultat .= "#\n";
	
	$resultat;
}

############################################
# translate_number:
#
# translate a number into words.

sub translate_number
{
	my $nombre = shift;
	my $triplet = "";
	my $puissance = 0;
	my $resultat = "";
	my $intro = "";
	
	if( $nombre == 0 )
	{
		return "zéro";
	}
	
	$nombre =~ s/^(0*)(.*)/$2/;
	$zeros = length($1);
	
	while( $zeros != 0 )
	{
		$intro .= " zéro";
		$zeros--;
	}

	while( $nombre =~ /(.*)(\d\d\d)/ )
	{
		$triplet = $2;
		$nombre = $1;
		$resultat = translate_triplet( $triplet, $puissance ). $resultat;
		$puissance++;
		if( $puissance == 4 )
		{
			$puissance = 1;
		}
	}

	$resultat = translate_triplet( $nombre, $puissance ). $resultat;

	$intro . $resultat;
}

sub translate_triplet
{
	my $triplet = shift;
	my $puissance = shift;
	my $centaine = 0;
	my $dizaine = 0;
	my $unite = 0;
	my $resultat = "";
	my $triplet2;
	
	$triplet = sprintf( "%3s", $triplet );
	$triplet2 = $triplet;
	$triplet2 =~ s/\s/0/g;
	$triplet2 =~ /(\d)(\d)(\d)/;
	$centaine = $1;
	$dizaine = $2;
	$unite = $3;
	
	if( $triplet == 0 )
	{
		return "";
	}
	
	if( ($triplet == 1) && ($puissance == 1) )
	{
		return @puissances[1];
	}
	
	if( $centaine != 0 )
	{
		if( $centaine != 1 )
		{
			$resultat .= translate_chiffre( $centaine );
		}
		$resultat .= " cent";
	}
	
	if( $dizaine == 0 )
	{
		$resultat .= translate_chiffre( $unite );
	}
	else
	{
		$resultat .= @dizaines[$dizaine];
		
		if( ($dizaine == 2) && ($unite != 0) )
		{
			$resultat .= "t";
		}
		
		if( ($dizaine == 1) || ($dizaine == 7) || ($dizaine == 9))
		{
			if( ($dizaine == 7) && ($unite == 1) )
			{
				$resultat .= " et";
			}
			$resultat .= translate_chiffre( 10 + $unite );
		}
		else
		{
			if( $unite == 1 )
			{
				if( $dizaine != 8 )
				{
					$resultat .= " et";
				}
			}
			if( $unite != 0 )
			{
				$resultat .= translate_chiffre( $unite );
			}
		}
	}


	$resultat .= @puissances[$puissance];
	
	$resultat;
}

sub translate_chiffre
{
	my $chiffre = shift;
	my $resultat = "";
	
	@nombres[$chiffre];
}