#!/usr/bin/perl

#######################################################################
# 
# WordSynth - Randomly generate words from a language rules file
# 
# Copyright (C) 2000  Ken St-Cyr
# 
# 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.,
# 675 Mass Ave, Cambridge, MA 02139, USA.
# 
# 
# Version 1.3
# 
#######################################################################

use Getopt::Std;

%tableExec = (
   'syllableStressPatterns'      => \&parse_std_table,
   'initialSyllables'            => \&parse_std_table,
   'internalSyllables'           => \&parse_std_table,
   'terminalSyllables'           => \&parse_std_table,
   'assimilationFilters'         => \&parse_pair_table,
   'wordInitialConsonants'       => \&parse_std_table,
   'wordInitialVowels'           => \&parse_std_table,
   'internalInitialConsonants'   => \&parse_std_table,
   'internalStressedVowels'      => \&parse_std_table,
   'internalUnstressedVowels'    => \&parse_std_table,
   'internalFinalConsonants'     => \&parse_std_table,
   'wordFinalVowels'             => \&parse_std_table,
   'wordFinalConsonants'         => \&parse_std_table,
);

%indexByLetter = (
   'C' => 'wordInitialConsonants',
   'c' => 'internalInitialConsonants',
   'A' => 'wordInitialVowels',
   'a' => 'wordFinalVowels',
   'V' => 'internalStressedVowels',
   'v' => 'internalUnstressedVowels',
   'k' => 'internalFinalConsonants',
   'K' => 'wordFinalConsonants',
);

########################################################################
# language file parse routines

# The table parsing functions return hash references to data loaded
# from a single table read from the language file.

# parse_std_table:
#  The std_table is an element,weight pair; the weights are totalled by
#  this function
#
sub parse_std_table
{
   my %tmphash = ();
   my $hashref = $tmphash;
   my $totalweight = 0;

   while (<INF>) {
      chomp;
      next if /^\s*(#|$)/;     # skip comments and newlines
      last if /END/;           # done reading this table
      ($tmpvalue, $tmpkey) = split /,/, $_;
      next if ($tmpkey eq ""); # skip if key has no value
      $totalweight += $tmpkey;
      $hashref->{$totalweight} = $tmpvalue;
   }

   return $hashref;
}

# parse_pair_table:
#   The pair_table is a pair of elements; no weights are totalled
#
sub parse_pair_table
{
   my %tmphash = ();
   my $hashref = $tmphash;
   my $tmpkey = 0;

   while (<INF>) {
      chomp;
      next if /^\s*(#|$)/;     # skip comments and newlines
      last if /END/;           # done reading this table
      ($tmpval1, $tmpval2) = split /,/, $_;
      # use tmpkey to maintain order of list
      $hashref->{$tmpkey} = [ $tmpval1, $tmpval2 ];
      ++$tmpkey;
   }

   return $hashref;
}

# read_language_file:
#  Open the language rules file for reading, find the start of each
#  table specification, then call the appropriate parsing function
#
sub read_language_file
{
   my $filename = shift;
   my $type = "";

   open INF, "$filename" or die "Can't open input file";
   while (<INF>) {
      # get TYPE, later use this to determine which variable holds hash
      chomp;
      if (/TYPE/) {
         ($junk, $type) = split;
         # set value of appropriate hash table
         if ($tableExec{$type}) {
            $tableRefs{$type} = &{$tableExec{$type}};
         }
      }
   }
   close(INF);
}


#######################################################################
# utility subroutines
###

# consult_table (name of table)
# tests each key against die roll, returning the first key
# that is lower than the threshold
sub consult_table
{
   my $table = shift;
   my @keylist = (sort { $a <=> $b } keys(%{$tableRefs{$table}}));
   my $threshold = 0;
   my $index = 0;

   # randomly generate a lookup index
   my $lookup = int (rand($keylist[-1]) + 1);

   # sort weights from lowest to highest 
   # then return entry corresponding to dieroll
   foreach $threshold (@keylist) {
      if ($lookup <= $threshold) {
         $index = $threshold;
         last;
      }
   }

   return ($tableRefs{$table}->{$index});
}

#######################################################################
# word building routines
###

# build_syllable(list-of-letter-types)
# builds a syllable by letter-types
# e.g., build_syllable('C','V','K')
# returns a randomly generated syllable in which
# the first character will be an initial stressed
# consonant, the second a stressed vowel, and the
# third a word final consonant
#
sub build_syllable
{
   my $stress = shift;
   my @letterList = @_;
   my $syllable = "";
   my $ltridx = "";

   foreach $ltridx (@letterList) {
      if ($stress eq 'H') {
         $ltridx =~ s/v/V/;
      } else {
         $ltridx =~ s/V/v/;
      }
      $syllable .= consult_table($indexByLetter{$ltridx});
   }

   return $syllable;
}

sub filter_word
{
   my $word = shift;
   my @rexlist = sort { $a <=> $b } keys(%{$tableRefs{'assimilationFilters'}});
   foreach $idx (@rexlist) {
      $rex = ${$tableRefs{'assimilationFilters'}->{$idx}}[0];
      $nrex = ${$tableRefs{'assimilationFilters'}->{$idx}}[1];
      $word =~ s/$rex/$nrex/g;
   }
   return $word;
}

sub build_word
{
   my $word = "";
   my $stress = 'H';

   # future work:  make syllableStressPatterns table also the
   # syllableStress table, using L and H to represent low and high
   # stress syllables.  A single syllable word might be simply 'H', but
   # a three syllable word could be LHL, LHH, HLH, LLL, etc.
   #
   @syllableStress = split //, consult_table('syllableStressPatterns');
   $numSyllables = scalar @syllableStress;

   if ($numSyllables == 1) {
      @myletterlist = consult_table('terminalSyllables');
      $word = build_syllable($syllableStress[0], split //, consult_table('terminalSyllables'));
   } elsif ($numSyllables == 2) {
      $word = build_syllable($syllableStress[0], split //, consult_table('initialSyllables'));
      $word = $word . build_syllable($syllableStress[1], split //,
                                     consult_table('terminalSyllables'));
   } else {
      $word = build_syllable($syllableStress[0], split //,
                             consult_table('initialSyllables'));
      for ($ns = 1; $ns < $numSyllables - 1; $ns++) {
         $word = $word . build_syllable($syllableStress[$ns], split //,
                                        consult_table('internalSyllables'));
      }
      $word = $word . build_syllable($syllableStress[$ns],
                         split //, consult_table('terminalSyllables'));
   }

   $word = filter_word($word);
   return $word;
}

########################################################################
# application start
###

sub usage
{
   print <<EOT;
Usage:
   $0 [-N n] <language-file>
-N<n>   number of words to print
EOT
   exit 1;
}

sub parse_args
{
   if ($#ARGV < 0) { usage() }
   getopts('N:h');
   if (defined $opt_h) { usage() }
   $NUMBER_OF_WORDS = defined $opt_N ? $opt_N : 1;
   $LANGUAGE_FILE = $ARGV[0];
}

sub mainApp
{
   parse_args();

   srand (time() ^ ($$ + ($$ << 15)));

   read_language_file($LANGUAGE_FILE);

   for ($qty = 0; $qty < $NUMBER_OF_WORDS; $qty++) {
      print build_word(), "\n";
   }
}

###

mainApp();