#! /usr/bin/perl
#
# Set $NoDbm to non-zero if you do NOT want to use the dbm (everything must fit in RAM)
my $NoDbm = 0;
#	
# TranscribeCGN.pl converts orthographic texts to CGN phonetic transcripts
# using a dictionary of Grapheme=>Phoneme word-pairs (tab separated).
# A "word" can consist of two separate orthogrqphic words, e.g., 'Agnus Dei'.
# All words from texts are tested in LOWERCASE.
# Unknown text words are marked as '*<word>*'.
# Lines starting with '# <ENTRY> ... </ENTRY>' are interpreted as containing 
# lexical entries which are added to the dictionairy, e.g., 
# <ENTRY><LEXEME>Jorinde</LEXEME><CGN>jO-"rIn-d@</CGN><CLASS>N</CLASS></ENTRY>
# Note that the complete entry must be present on a single line!
#
# use:
# TranscribeCGN.pl <Dictionary> <file1> <file2>
# cat <file1> <file2> | TranscribeCGN.pl <Dictionary>
#
# TranscribeCGN can be "require"-d. 
# This program is very straightforeward. It reads a large transcription dictionary
# and just replaces words with their transcription. If a transcription is not found,
# it splits the word on '-' dashes, and looks up the parts. If this doesn't help, it
# tries to split the word in compounds that are themselves existing words (this is
# done recursively). There are some simple (language specific) additions to incorporate
# connection rules in compoundwords.
#          
#
# Author: Rob van Son 
#         email:
#	  Rob.van.Son@hum.uva.nl
# 	  rob.van.son@workmail.com (more private)
# 	  mail:
# 	  Institute of Phonetic Sciences
# 	  University of Amsterdam
# 	  Herengracht 338
# 	  NL-1016CG Amsterdam
# 	  The Netherlands
# 	  tel +31 205252183
# 	  fax +31 205252197
# 	  
# Date:   July 6, 1999
# Version:1.0
# Env:    Perl 5.002
#
################################################################################
#                                                                              #
#          LICENCE                                                             #
#                                                                              #
#          This program is free software; you can redistribute it and/or       #
#          modify it under the terms of the GNU General Public License         #
#          as published by the Free Software Foundation; either version 2      #
#          of the License, or (at your option) any later version.              #
#                                                                              #
#          This program is distributed in the hope that it will be useful,     #
#          but WITHOUT ANY WARRANTY; without even the implied warranty of      #
#          MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       #
#          GNU General Public License for more details.                        #
#                                                                              #
#          You should have received a copy of the GNU General Public License   #
#          along with this program; if not, write to the Free Software         #
#          Foundation, Inc., 59 Temple Place - Suite 330,                      #
#          Boston, MA  02111-1307, USA.                                        #
#                                                                              #
################################################################################
#
use SDBM_File;
use POSIX;
#
# The user definable transcription table
# Start with punctuation
my %UserCGNTranscriptionTable = (
'.' => '.',
',' => ',',
';' => ';',
"'" => "`",
'"' => '`',
'`' => '`',
':' => ':',
'?' => '?',
'!' => '!',
'eeen' => '"e:n'	# Special transcription of nummeral
);

######################################################
#                                                    #
#                                                    #
#    Conversion Table to go from CGN to CGN labels   #
#                                                    #
#                                                    #
######################################################
my %SAMPAtoCGNtable =
(
'p' => 'p',
'b' => 'b',
't' => 't',
'd' => 'd',
'k' => 'k',
'g' => 'g',
'f' => 'f',
'v' => 'v',
's' => 's',
'z' => 'z',
'S' => 'S',
'Z' => 'Z',
'x' => 'x',
'G' => 'G',
'h' => 'h',
'N' => 'N',
'm' => 'm',
'n' => 'n',
'nj' => 'J',
'l' => 'l',
'r' => 'r',
'w' => 'w',
'j' => 'j',
'I' => 'I',
'E' => 'E',
'A' => 'A',
'O' => 'O',
'}' => 'Y',
'i:' => 'i',
'y:' => 'y',
'e:' => 'e',
'|:' => '2',
'a:' => 'a',
'o:' => 'o',
'u:' => 'u',
'@' => '@',
'EI' => 'E+',
'/I' => '9+',
'Au' => 'O+',
'E:' => 'E:',
'/:' => '9:',
'Q:' => 'O:',
'E~' => 'E~',
'A~' => 'A~',
'O~' => 'O~',
'Y~' => 'Y~'
);

# Convert SAMPA phoneme labels into CGN phoneme lables
sub SAMPAtoCGN	# (SAMPAstring) -> CGNstring
{
	my $string = shift || "";
	$string =~ 
	s/([\/\@AEIOQIYiyaeou29\|\}]{2}|\S[\+\~\:]?)/$SAMPAtoCGNtable{"$1"} ? $SAMPAtoCGNtable{"$1"} : $1;/iseg;
	return $string;
};

#######################################################################

# The variable with the dictionary
%CGNTranscriptionTable = ();

# Connect to the database (or create it if necessary)
my $DBMconnect = 0;
$DBMconnect = require 'GTPhconvdbm.pl' unless $NoDbm;
my $NoReadCLASSdbm = $DBMconnect && (-e "CGNdbm.pag");  # Does the dbm exist?

#
# Connect to the database, READ-ONLY
tie(%CGNTranscriptionTable, GTPhconvdbm, "/home/rob/OSS/GTPhconv/CGNdbm", O_RD, 0640) if $DBMconnect;

# 
# Function to look up transcriptions
sub LookUpCGN	# (String) -> Lookup;
{
    my $Word = shift;
    $Word = lc($Word);
    my $LookUpCGNResult = "";
    $LookUpCGNResult = exists($UserCGNTranscriptionTable{$Word})
    		? $UserCGNTranscriptionTable{$Word}
    		: $CGNTranscriptionTable{$Word};
    return $LookUpCGNResult;
}

# Transcribe a list of Orthographic words to phonetic symbols
sub TranscribeCGNlist   # (@Words) -> $TranscribedLine
{
    my @Words = @_;
    my @TranscribedWordsList = ();
    while(@Words)
    {
	my $Transcription;
	if($Words[0] =~ /^\<.*\>$/)
	{
	    $Transcription = $Words[0];
	    shift(@Words);
	}
	elsif($Words[1] && ($Transcription = LookUpCGN("$Words[0] $Words[1]")))
	{
	    shift(@Words);
	    shift(@Words);
	}
	elsif($Transcription = LookUpCGN($Words[0]))
	{
	    shift(@Words);
	}
	elsif($Words[0] =~ /\-/)
	{
	    my @CompoundWordList = split(/\-/, $Words[0]);
	    my @CompoundWordTranscription = TranscribeCGNlist(@CompoundWordList);
	    $Transcription = join('-', @CompoundWordTranscription);
	    shift(@Words);
	}
	else	# Word not found: PANIC
	{
	    my @CharacterList = split('', $Words[0]);
	    my $RestWord = pop(@CharacterList);  # Start with 2 characters, or else you get spelling
	    #
	    # Search for compound words, this is done recursively starting with the largest "onset"!
	    # You will find language specific rules for compound word formation
	    while(@CharacterList)
	    {
		my $NextChar = pop(@CharacterList);
		next unless $NextChar;           # Skip null characters
		my @CompoundWordTranscriptionList = ();
		
		$RestWord = $NextChar.$RestWord;
		my $SubWord = join("", @CharacterList);
		my $SubWordTranscription = "";
		my @RestWordTranscription = ();
		
		# Handle initial subword, NEXT ITERATION IF UNKNOWN SUBWORD
		next unless (length($SubWord) > 1);       # NO single character words
		# Lookup word, word-s, and word-n (added connection-s and removed -n, language specific)
		next unless ($SubWordTranscription = LookUpCGN($SubWord))
		|| ($SubWord =~ /(\w\w)s$/ && ($SubWordTranscription = LookUpCGN($1.$`)) 
		&& ($SubWordTranscription .= 's')) 
		|| ($SubWord =~ /e$/ && ($SubWordTranscription = LookUpCGN($SubWord.'n')));
		push(@CompoundWordTranscriptionList, $SubWordTranscription); # Partial Success
		
		# Handle the rest recursively
		next unless length($RestWord) > 1;       # NO single character words
		@RestWordTranscription = TranscribeCGNlist($RestWord);
		# Realy unknown
		next if grep(/\*/, @RestWordTranscription); # Restword unknown
		
		push(@CompoundWordTranscriptionList, @RestWordTranscription);
		$Transcription = join("-", @CompoundWordTranscriptionList);
		@CharacterList = ();
		last;
	    };
	    
	    # Maybe it is an all-uppercase Letter Abreviation?
	    unless($Transcription || $Words[0] =~ /[^A-Z]/)
	    {
		my @CharacterList = split('', $Words[0]);
		last unless scalar(@CharacterList) > 1;
		my @CharacterListTranscription = TranscribeCGNlist(@CharacterList);
		$Transcription = join("-", @CharacterListTranscription);
	    };
	    
	    # Total Failure. Give up and mark the unknown word
	    $Transcription = "*$Words[0]*" unless $Transcription;
	    shift(@Words);
	};
	push(@TranscribedWordsList, $Transcription);
    };
    return @TranscribedWordsList;
};

# Line text interface to TranscribeCGNlist (which uses a list of words)
sub TranscribeCGNstring   # ($Line) -> $TranscribedLine
{
    my $Line = shift;
    #
    # Enter new words in the dictionary, 
    # note that the WHOLE <ENTRY></ENTRY> Tag must be present in Line
    if($Line =~ /^\#\s+/isg)    # Comments
    {
	$Line =~ /^\#\s+\<ENTRY\>\s*/is;   # New dictionary entries
	my $Entry = $';
	$Entry =~ m@\s*\</ENTRY\>@is;
	$Entry = $`;
	
	# Get the Lexeme
	$Entry =~ m@\<LEXEME\>\s*@is;
	my $Lexeme = $';
	$Lexeme =~ m@\s*\</LEXEME\>@is;
	$Lexeme = $`;
	
	# Get the Transcription
	$Entry =~ m@\<CGN\>\s*@is;
	my $CGN = $';
	$CGN =~ m@\s*\</CGN\>@is;
	$CGN = $`;

	my $CGNPresent = 1 if $CGN;
	
	$UserCGNTranscriptionTable{lc($Lexeme)} = $CGN 
	if $CGNPresent; # Skip if no transcription
	
	return $Line;
    };
    
    my @Words = ();
    while($Line =~ /\<[^\>]*\>/)
    {
	$Line = $';
	push(@Words, split(' ', $`), $&);
    };
    push(@Words, split(' ', $Line));
    
    my @TranscribedWordsList = TranscribeCGNlist(@Words);
    return (join(" ", @TranscribedWordsList))."\n";
}
#
#
# Use the phoneme transcription to select a minimum set of lines with
# a maximum coverage of Phonemes, Di-, Tri-phones, or Syllables.
# As this is only usefull for LARGE corpora of sentences, it is tried 
# to minimize the copying of lists of text. Note that the number of
# comparisons to determine "best coverage" scales as (#Lines)**2.
# 
# The input text is divided in groups of lines.  Each group maximizes
# coverage of the input text minus the preceding lines.

# Add a transcription into space-separated phonemes of the sentence between <>-brackets.
# Do not remove punctuation yet.
sub InsertPhonemeTranscription	# (\@AllLines) -> \@NewLines
{
    my $AllLines = shift;
    my $Line;
    foreach $Line (@$AllLines)
    {
	my $CGNLine = ::TranscribeCGNstring($Line);
	next if $Line =~ /^\s*\#\s+/;			# Skip comments and new entries
        chomp $CGNLine;    # Remove newlines
	$CGNLine =~ s/\<[^\>]*\>|\*[^\*]*\*//isg;	# Remove <> and unknown words
	# Handle ambiguities
	while($CGNLine =~ /\[\s*([^\]]*)\s*\]/)
	{
	    my $Pre = $`;
	    my $Match = $1;
	    my $Post = $';
	    my @AmbiguousWords = sort {length($a) <=> length($b)} split(' ', $Match);
	    $Match = $AmbiguousWords[0];
	    $CGNLine = $Pre.$Match.$Post;
	};
        # Remove multiple spaces and syllable markers
	$CGNLine =~ s/[\s\-]+/ /isg;
        # Concatenate diphthongs and \: lengthening
	$CGNLine =~ s/([\/\@AEIOQIYiyaeou29\|\}]{2}|\S[\+\~\:]?)/ $1 /isg;
	my @PhonemeList = grep(/\S/, split(' ', $CGNLine));
	$Line = "< @PhonemeList >\t$Line" if @PhonemeList;
    };
    return $AllLines;
}
#
# Select lines on coverage. Uses a list of "< elements >\tOriginal-Line-of-Text" lines.
# NOTE: This routine is defined in several other scripts. This is done to make the scripts
# "stand-alone". The version in TranscribeCGN.pl is the authorative one.
sub SelectCGNCoverage	# (\@AllLines) -> \@CoveredLines
{
    my $AllLines = shift;
    my @CoveredLines = ();
    my @CoveredList = ();
    # Save comments and new entries
    my  $Line;
    foreach $Line (@$AllLines)
    {
	(push(@CoveredLines, $Line), ($Line = "")) if $Line =~ /^\s*\#\s+/;	# Skip comments and new entries
    };
    # Clean up @$AllLines
    @$AllLines = grep {/\S/} @$AllLines;
    # Extract all elements and put them in a single Master list
    my @MasterElementLists = ();
    my  $i;
    for($i=0; $i<scalar(@$AllLines); ++$i)
    {
        $MasterElementLists[$i] = "";
	next unless $AllLines->[$i] =~ /^\s*\<\s+([^\>]*)\s+\>\t/;	# Get (empty) element list
	my @ThisElementList = split(' ', $1);
	$AllLines->[$i] = "" unless @ThisElementList;
	next unless @ThisElementList;
	$MasterElementLists[$i] = \@ThisElementList;
    };
    #
    # Process all input 
    # (you might want to look at the efficiency of 
    #  this when you use >10^5 lines)
    # Stop after SQRT(scalar(@$AllLines)) sets
    my $NextSet = sqrt(scalar(@$AllLines));
    while($AllLines && @$AllLines)
    {
	@CoveredList = ();
	# Select lines for coverage
	my $MaxElementLine = -1;
	my @ElementLists = ();
        for($i=0; $i<scalar(@MasterElementLists); ++$i)
        {
	    @{$ElementLists[$i]} = @{$MasterElementLists[$i]};
        };
        # 
	do
	{
            # Nothing Done condition
	    $MaxElementLine = -1;
            # Which line is covers the most elements?
	    my  $i;
	    for($i=0; $i<scalar(@$AllLines); ++$i)
	    {
		next unless $AllLines->[$i] =~ /\S/;			# Skip empty lines
		next unless @{$ElementLists[$i]};		        # Skip lines with no contribution
		@{$ElementLists[$i]} = grep {$my = $_; !grep {$_ eq $my;} @CoveredList} @{$ElementLists[$i]};
		$MaxElementLine = $i if $MaxElementLine < 0 && @{$ElementLists[$i]};   # Initialization
		# If this is a better choice, switch lines (more elements or shorter line)
		if((scalar(@{$ElementLists[$i]}) > scalar(@{$ElementLists[$MaxElementLine]}) ||	# More elements
		(scalar(@{$ElementLists[$i]}) > 0 &&
		(scalar(@{$ElementLists[$i]}) == scalar(@{$ElementLists[$MaxElementLine]}))	# equal number of elements
		&& length($$AllLines[$i]) < length($$AllLines[$MaxElementLine]))))	# and shorter line
		{
		    $MaxElementLine = $i;
		};
	    };
            # If there is a best line, copy it to the output list and remove it from the list
	    if($MaxElementLine > -1)
	    {
                # Add the elements covered to the line
		my $NewElementString = join(" ", @{$ElementLists[$MaxElementLine]});
		$$AllLines[$MaxElementLine] =~ s/^\s*\<\s+([^\>]+)\s+\>\t/\< $NewElementString \>\t/isg;
                # Put the line on the output list
		push(@CoveredLines, $$AllLines[$MaxElementLine]);
                # Add new elements to the list of elements covered
		push(@CoveredList, @{$ElementLists[$MaxElementLine]});
                # Remove the lines already covered (that is, make them empty)
		$$AllLines[$MaxElementLine] = "";
                @{$ElementLists[$MaxElementLine]} = "";
                $MasterElementLists[$MaxElementLine] = "";
	    };
	} while($MaxElementLine > -1);
	push(@CoveredLines, "\n", "\n");   # Two empty lines
	# Clean up @AllLines and the @MasterElementLists (i.e., remove empty lines)
        # The @ElementList will be initialized anyway
	@$AllLines = grep {/\S/} @$AllLines;
	@MasterElementLists = grep {$_} @MasterElementLists;
	unless($NextSet > 0)
	{
	    # Ready, enough sets done
	    push(@CoveredLines, @$AllLines);    # Append rest on lines
	    $AllLines = 0; 		# No new sets
	};
	--$NextSet;  # One set less to do
    };
    return \@CoveredLines;
}
#
# Clean up Text lines
sub CleanUpLineCGN    # ($line) -> $CleanLine
{
    my $CleanLine = shift || "";
    $CleanLine =~ s/[\"\.\,\`\!\?\;]//isg;   # Remove punctuation
    $CleanLine =~ s/ \://isg;                # Remove punctuation
    $CleanLine =~ s/\s*\<[^\>]*\>\s*/ /isg;   # Remove bracketted words
    $CleanLine =~ s/\s\*[^\*]*\*\s/ /isg;     # Remove unknown words
    return $CleanLine;
}
#
# Select lines on maximal Phoneme coverage
sub PhonemeCoverageCGN
{
    my $AllLines = shift;
    $AllLines = InsertPhonemeTranscription($AllLines); 
    my $Line;
    # Construct Phoneme inventory
    foreach $Line (@$AllLines)
    {
	next unless $Line =~ /\S/;
	next if $Line =~ /^\s*\#/;
	my $CGNLine = "";
	if($Line =~ /^\s*\<\s+([^\>]+)\s+\>\t/)
	{
	    $Line = $' ;
	    $CGNLine = CleanUpLineCGN($1);
	};

	my @PhonemeList = split(' ', $CGNLine);
	my $last = "";
	@PhonemeList = map {($_ ne $last && ($last = $_) )? $_ : ();} sort @PhonemeList; # i.e., sort | uniq
	$Line = "< @PhonemeList >\t$Line";
    };
    return SelectCGNCoverage($AllLines);
}

#
# Select lines on maximal Diphone coverage (across words)
sub DiphoneCoverageCGN	# (\@AllLines) -> \@CoveredLines;
{
    my $AllLines = shift;
    $AllLines = InsertPhonemeTranscription($AllLines); 
    my $Line;
    foreach $Line (@$AllLines)
    {
	next unless $Line =~ /\S/;
	next if $Line =~ /^\s*\#/;
	my $CGNLine = "";
	if($Line =~ /^\s*\<\s+([^\>]+)\s+\>\t/)
	{
	    $Line = $' ;
	    $CGNLine = CleanUpLineCGN($1);
	};

	my @PhonemeList = split(' ', $CGNLine);
	# Combine Phonemes to Di-phones
	my @DiphoneList = ();
	while(scalar(@PhonemeList) >= 2)	# Diphones
	{
	    my $Diphone = join("", @PhonemeList[0..1]);  
	    push(@DiphoneList, $Diphone) unless $Diphone =~ /[\"\.\,\`\!\?\;]/;
	    shift(@PhonemeList);
	};
        # No diphones: PANIC, start anew
        unless(@DiphoneList)
        {
	    @PhonemeList = grep(/[^\"\.\,\`\!\?\;]/, split(' ', $CGNLine));
            push(@DiphoneList, join("", @PhonemeList));
        };
	# Make an inventory of diphones
	my $last = "";
	@DiphoneList = map {($_ ne $last && ($last = $_) )? $_ : ();} sort @DiphoneList; # i.e., sort | uniq
	$Line = @DiphoneList ? "< @DiphoneList >\t$Line" : "";
    };
    #
    $AllLines = SelectCGNCoverage($AllLines);
    # Replace biphone lists bij  number of biphones
    foreach $Line (@$AllLines)
    {
	next unless $Line =~ /^\<\s*([^\>]*)\s*\>\t/;
	$Line = "< ".scalar(split(' ', $1))." >\t$'";
    };
    return $AllLines;
}

#
# Select lines on maximal Triphone coverage (across words)
sub TriphoneCoverageCGN
{
    my $AllLines = shift;
    $AllLines = InsertPhonemeTranscription($AllLines); 
    my $Line;
    foreach $Line (@$AllLines)
    {
	next unless $Line =~ /\S/;
	next if $Line =~ /^\s*\#/;
	my $CGNLine = "";
	if($Line =~ /^\s*\<\s+([^\>]+)\s+\>\t/)
	{
	    $Line = $' ;
	    $CGNLine = CleanUpLineCGN($1);
	};

	my @PhonemeList = split(' ', $CGNLine);
	# Combine Phonemes to Tri-phones
	my @TriphoneList = ();
	while(scalar(@PhonemeList) >= 3)	# Triphones
	{
	    my $Triphone = join("", @PhonemeList[0..2]);  
	    push(@TriphoneList, $Triphone) unless $Triphone =~ /[\"\.\,\`\!\?\;]/;
	    shift(@PhonemeList);
	};
        # No triphones: PANIC, start anew
        unless(@TriphoneList)
        {
	    @PhonemeList = grep(/[^\"\.\,\`\!\?\;]/, split(' ', $CGNLine));
            push(@TriphoneList, join("", @PhonemeList));
        };
	# Make an inventory of triphones
	$last = "";
	@TriphoneList = map {($_ ne $last && ($last = $_) )? $_ : ();} sort @TriphoneList; # i.e., sort | uniq
	$Line = @TriphoneList ? "< @TriphoneList >\t$Line" : "";
    };
    #
    $AllLines = SelectCGNCoverage($AllLines);
    # Replace Triphone lists bij  number of triphones
    foreach $Line (@$AllLines)
    {
	$Line =~ s/^\<\s*([^\>]*)\s*\>\t/"< ".scalar(split(' ', $1))." >\t"/iesg;
    };
    return $AllLines;
}

#
# Select lines on maximal syllable coverage
sub SyllableCoverageCGN
{
    my $AllLines = shift;
    my $Line;
    foreach $Line (@$AllLines)
    {
	next unless $Line =~ /\S/;
	my $CGNLine = ::TranscribeCGNstring($Line);
	next if $Line =~ /^\s*\#\s+/;			# Skip comments and new entries
	my $CGNLine = "";
	if($Line =~ /^\s*\<\s+([^\>]+)\s+\>\t/)
	{
	    $Line = $' ;
	    $CGNLine = CleanUpLineCGN($1);
	};
	# Handle ambiguities
	while($CGNLine =~ /\[\s*([^\]]*)\s*\]/)
	{
	    next unless $Line =~ /\S/;
	    my $Pre = $`;
	    my $Match = $&;
	    my $Post = $';
	    my @AmbiguousWords = sort {length($a) <=> length($b)} split(' ', $Match);
	    $Match = $AmbiguousWords[0];
	    $CGNLine = $Pre.$Match.$Post;
	};
	$CGNLine =~ s/[\"\.\,\`\!\?\;]//isg;   # Remove punctuation
	$CGNLine =~ s/[\s\-]+/ /isg;
	# Make an inventory of syllables
	$last = "";
	my @SyllableList = map {($_ ne $last && ($last = $_) )? $_ : ();} sort split(' ', $CGNLine); # i.e., sort | uniq
	$Line = "< @SyllableList >\t$Line" if @SyllableList;
    };
    #
    $AllLines = SelectCGNCoverage($AllLines);
    # Replace Syllable lists bij number of syllables
    foreach $Line (@$AllLines)
    {
	$Line =~ s/^\<\s*([^\>]*)\s*\>\t/"< ".scalar(split(' ', $1))." >\t"/iesg;
    };
    return $AllLines;
};

# Read and convert all sentences from STDIN from words to graphemes,
# but only when NOT called inside another program.
unless(caller())
{
    while(<>)
    {
	my @Words = ();
	my $Transcription;
	my $Ortheem;
	
	my $TranscribedLine = TranscribeCGNstring($_);
	
	print STDOUT $TranscribedLine;
    };
};

# Make require happy
1;
