File Coverage

blib/lib/Silly/Werder.pm

Criterion	Covered	Total	%
statement	113	478	23.6
branch	27	168	16.0
condition	8	23	34.7
subroutine	14	33	42.4
pod	16	18	88.8
total	178	720	24.7

# Copyright 2000-2002 Dave Olszewski.  All rights reserved.
# Perlish way to generate snoof (language which appears to be real but is
#  in fact, not)
# Distributed under the terms of GPL Version 2

package Silly::Werder;

$Silly::Werder::VERSION='0.90';

use strict;
use Exporter;
use Storable;
use File::Spec::Functions;

use constant SENTENCE     => ".";
use constant QUESTION     => "?";
use constant EXCLAMATION  => "!";

use vars qw($VERSION $PACKAGE
            @ISA
            @EXPORT_OK
           );

@ISA = 'Exporter';

my @werder_functions = qw(line sentence question exclaimation exclamation
                          set_werds_num set_syllables_num set_language
                          set_hard_syllable_max end_with_newline get_werd
                          set_unlinked dump_syllables dump_grammar build_grammar
                          load_grammar_file load_syllable_file
                          set_cons_weight);

@EXPORT_OK = (@werder_functions);

my $self;

sub new {
  my $self = {};
  bless $self;

  # Initialize the internal variables
  $self->_init($self);

  return $self;
}

sub DESTROY { }

##########################################################################
#  Sets the min and max number of werds that will go into the sentence
##########################################################################
sub set_werds_num($$) {

  my $obj;
  if(scalar(@_) == 3) {
    $obj = shift;
  }

  my ($min, $max) = @_;
  my $target;
  if($min > $max) { return -1; }

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  $target->{"min_werds"} = $min;
  $target->{"max_werds"} = $max;

  return 0;

}


##########################################################################
#  Sets the min and max number of syllables that can go into a werd
##########################################################################
sub set_syllables_num($$) {

  my $obj;
  if(scalar(@_) == 3) {
    $obj = shift;
  }

  my ($min, $max) = @_;
  my $target;
  if($min > $max) { return -1; }

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  $target->{"min_syllables"} = $min;
  $target->{"max_syllables"} = $max;

  return 0;

}


##########################################################################
#  Sets a hard max syllables per werd
##########################################################################
sub set_hard_syllable_max($) {

  my $obj;
  if(scalar(@_) == 2) {
    $obj = shift;
  }

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $max = shift;
  if($max < 0) { return -1; }
  if($max < $target->{"syllables_min"}) { return -1; }

  $target->{"hard_syllable_max"} = $max;

  return 0;
}


##########################################################################
#  Sets whether you want to end sentences in a newline
##########################################################################
sub end_with_newline($) {

  my $obj;
  if(scalar(@_) == 2) {
    $obj = shift;
  }

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $yesno = shift;

  $target->{"end_with_newline"} = $yesno;

  return 0;
}


##########################################################################
#  Sets whether you want fully random mode or not (not recommended)
##########################################################################
sub set_unlinked($) {
  my $obj;
  if(scalar(@_) == 2) {
    $obj = shift;
  }

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $yesno = shift;

  $target->{"unlinked"} = $yesno;

  return 0;
}

##########################################################################
#  Set the percentage of the time a werd will start with a consonant
#  This function is OBSOLETE and is only kept for compatibility
##########################################################################
sub set_cons_weight($) {
  return 0;
}

##########################################################################
#  Create a random type of sentence
##########################################################################
sub line {
  my $obj;
  if(scalar(@_) == 1) {
    $obj = shift;
  }

  my ($line, $target);
  my $which_kind = int(rand() * 3);


  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  if($which_kind == 0) { $line = _make_line($target, SENTENCE); }
  if($which_kind == 1) { $line = _make_line($target, QUESTION); }
  if($which_kind == 2) { $line = _make_line($target, EXCLAMATION); }

  return $line;
}

##########################################################################
#  Create a sentence with a period
##########################################################################
sub sentence {
  my $obj;
  if(scalar(@_) == 1) {
    $obj = shift;
  }

  my $target;

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $line = _make_line($target, SENTENCE);
  return $line;
}

##########################################################################
#  Create a question
##########################################################################
sub question {
  my $obj;
  if(scalar(@_) == 1) {
    $obj = shift;
  }

  my $target;

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $line = _make_line($target, QUESTION);
  return $line;
}

##########################################################################
#  Create an exclamation
##########################################################################
sub exclamation {
  my $obj;
  if(scalar(@_) == 1) {
    $obj = shift;
  }

  my $target;

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $line = _make_line($target, EXCLAMATION);
  return $line;
}

##########################################################################
#  Make and return a single werd
##########################################################################
sub get_werd {
  my $obj = shift;

  my $target;

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $werd = _make_werd($target);
  return $werd;
}

# For backwards compatibility with spelling error from previous release
# Do it twice to quelch "only used once" warnings
*exclaimation = *exclamation;
*exclaimation = *exclamation;

##########################################################################
#  Set the language/grammar to use
##########################################################################
sub set_language($) {
  my ($obj, $language, $variant) = @_;
  my $target;

  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $module = "Silly::Werder::" . $language;
  eval "require $module";
  import $module (qw/LoadGrammar/);

  my ($grammar, $index) = LoadGrammar($variant);
  $obj->{"grammar"} = $grammar;
  $obj->{"index"} = $index;
}



##########################################################################
#  Initialize class/object data
##########################################################################
sub _init {
  my $obj = shift;

  if(ref $obj) {
    $obj->{"min_werds"} = 5;
    $obj->{"max_werds"} = 9;

    $obj->{"min_syllables"} = 3;
    $obj->{"max_syllables"} = 7;
  }
  else {
    $self->{"min_werds"} = 5;
    $self->{"max_werds"} = 9;

    $self->{"min_syllables"} = 3;
    $self->{"max_syllables"} = 7;
  }
}

# Call the init function at the time we load the module to initialize the vars
# for class methods
_init();

##########################################################################
#  Called from _make_werd to make sure a grammar is loaded
##########################################################################
sub _check_grammar {
  my $obj = shift;

  if(!$obj->{"grammar"} or !$obj->{"index"}) {
    bless $obj; # a hack to get set_language to work
    $obj->set_language("English");
  }
}


##########################################################################
#  Internal method to make a single werd
##########################################################################
sub _make_werd {
  my ($obj, $target, $i);

  if(scalar(@_) == 1) {
    $obj = shift;
  }
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  _check_grammar($target);

  my $syl = "_BEGIN_";
  my $werd = "";
  my $which;
  my $sylcount = 0;

  # Full random mode
  if($target->{"unlinked"}) {
    my $syl_num = int(rand() * ($target->{"max_syllables"}
       - $target->{"min_syllables"} + 1)) + $target->{"min_syllables"};

    for(my $i = 0; $i < $syl_num; $i++) {

      do {
        $which = int(rand() * scalar(@{$target->{"grammar"}}));
      } while(($target->{"grammar"}[$which][0] eq "_BEGIN_") or
             ($target->{"grammar"}[$which][0] eq "_END_"));

      $werd .= $target->{"grammar"}[$which][0];
    }
    return($werd);
  }
  # Regular linked mode
  else {
    while($syl ne "_END_") {

      # End the word on time if we have a hard max set
      if(($target->{"hard_syllable_max"}) and
         ($sylcount >= $target->{"hard_syllable_max"})) {
        last;
      }

      $which = -1;
      if($syl ne "_BEGIN_") { $werd .= $syl; }
      my $offset = $target->{index}{$syl};
      my $count = scalar(@{$target->{"grammar"}[$offset][1]})
        if $target->{"grammar"}[$offset][1];
      if($sylcount >= ($target->{max_syllables} - 1)) {
        # Try to choose an ending
        $which = -1;
        for($i = 0; $i < $count; $i++) {
          if($target->{"grammar"}[$offset][1][$i][0] eq "_END_") {
            $which = $i;
            last;
          }
        }
      }
      if($which < 0) {
        my ($freq_total, $freq);

        foreach $freq (@{$target->{"grammar"}[$offset][2]}) {
          $freq_total+= $freq;
        }

        do {
          my ($freq_sum, $i, $which_freq);

          $which_freq = int(rand() * $freq_total + 1);
          for($i = 0; $i < scalar(@{$target->{"grammar"}[$offset][2]}); $i++) {
            $freq_sum += $target->{"grammar"}[$offset][2][$i];
            if($freq_sum >= $which_freq) {
              $which = $i;
              last;
            }
          }
        } while(($target->{"grammar"}[$offset][1][$which][0] eq "_END_") and
                ($count > 1) and ($sylcount < $target->{"min_syllables"}));
      }
      $syl = $target->{"grammar"}[$offset][1][$which][0];
      $sylcount++;
    }
  }

  return($werd);
}


##########################################################################
#  Internal method to make a line of werds
##########################################################################
sub _make_line {
  my ($obj, $target);

  if(scalar(@_) == 2) {
    $obj = shift;
  }
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $ending = shift;
  my ($line, $num_werds, $werd_counter);

  $num_werds = int(rand() * ($target->{"max_werds"}
      - $target->{"min_werds"} + 1) + $target->{"min_werds"});

  for($werd_counter = 0; $werd_counter < $num_werds; $werd_counter++) {
    $line .= " " . _make_werd($target);
  }

  $line =~ s/^.(.)/uc($1)/e;
  $line .= $ending;

  if($target->{"end_with_newline"}) {
    $line .= "\n";
  }

  return $line;
}


###########################################################
###                 GRAMMAR FUNCTIONS                   ###
###########################################################

##########################################################################
#  Load the syllable file
##########################################################################
sub _load_syllables {
  my $obj = shift;
  my $indexed_syllables;

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  (my $dir = $INC{'Silly/Werder.pm'}) =~ s/\.pm//;
  $dir = catdir($dir, 'data');
  my $syllable_file = catfile($dir, 'syllables');

  # Load the syllable list
  open SYLS, $syllable_file or return(-1);
  chomp(my @syllables = );
  close SYLS;

  # Sort the list, but sorting longer words higher
  @syllables=sort { my $min=(length($a) < length($b)) ? length($a) : length($b);
            ( substr(lc($a),0,$min) cmp substr(lc($b),0,$min) ||
              length($b) <=> length($a) )
            } @syllables;

  # Remove duplicates (important for recursive parse)
  for(my $i = 1; $i < scalar(@syllables); $i++) {
    if(lc($syllables[$i]) eq lc($syllables[$i - 1])) {
      @syllables = splice(@syllables, $i, 1);
      $i--;
    }
  }

  my $syl;
  foreach $syl (@syllables) {
    $syl =~ /^((.).?)/;
    my $first = lc($2);
    my $firsttwo = lc($1);
    if($first eq $firsttwo) { $firsttwo = "_"; }
    push @{$indexed_syllables->{$first}{$firsttwo}}, $syl;
  }

  $target->{"syllables"} = $indexed_syllables;

  return(0);
}

##########################################################################
#  Dump the syllables to a user named file
##########################################################################
sub dump_syllables($) {
  my $obj = shift;
  my (%syls, $syl, @syl_sort);

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  if(!$target->{"syllables"}) {
    if(_load_syllables($target) < 0) { return -1; }
  }

  my $syl_out_file = shift;
  open SYL_OUT, ">$syl_out_file" or return -1;

  # Un-hash the syllables into one big hash to make sure there's no dups
  foreach my $first (keys %{$target->{"syllables"}}) {
    foreach $syl (@{$target->{"syllables"}{$first}{_}}) {
      $syls{$syl} = 1;
    }
    foreach my $firsttwo (keys %{$target->{"syllables"}{$first}}) {
      foreach $syl (@{$target->{"syllables"}{$first}{$firsttwo}}) {
        $syls{$syl} = 1;
      }
    }
  }

  # Sort the list, but sorting longer words higher
  @syl_sort=sort { my $min=(length($a) < length($b)) ? length($a) : length($b);
            ( substr($a,0,$min) cmp substr($b,0,$min) ||
              length($b) <=> length($a) )
            } keys(%syls);


  foreach $syl(@syl_sort) {
    print SYL_OUT "$syl\n";
  }

  close SYL_OUT;

  return 0;
}

##########################################################################
#  Parse a word and pass back the syllable pairs and number of word variants
##########################################################################
sub _parse_werd($$$;$$$);
# Needs a prototype because it's recursive and Perl cries otherwise
sub _parse_werd($$$;$$$) {
  my ($target, $werd, $werd_account, $werd_parts, $variations, $start_at) = @_;
  my ($syl, $ready, $next_syl);

  # Make sure ref contains something;
  ${$variations} += 0;

  if($werd eq "") {
    my $first = $werd_parts->[0];
    my $last = $werd_parts->[$#{$werd_parts}];
    my $i;

    $werd_account->{"_BEGIN_"}{$first} = 1;
    $werd_account->{$last}{"_END_"} = 1;

    for($i = 1; $i <= $#{$werd_parts}; $i++) {
      $werd_account->{$werd_parts->[$i-1]}{$werd_parts->[$i]} = 1;
    }

    ${$variations}++;

    undef $werd_parts;
  }

  $werd =~ /^((.).?)/;
  my $first = lc($2);
  my $firsttwo = lc($1);
  # gotta remember to check for syls that are just 1 in length
  foreach $syl (@{$target->{"syllables"}{$first}{_}},
                @{$target->{"syllables"}{$first}{$firsttwo}}) {
    $next_syl = 0;
    if($start_at && !$ready) { $next_syl = 1; }
    if(($syl eq $start_at) || !$start_at) { $ready = 1; }
    next if $next_syl;


    if($werd =~ /^$syl(.*)$/si) {
      push @{$werd_parts}, $syl;
      _parse_werd($target, $1, $werd_account, $werd_parts, $variations);
      return(${$variations});
    }
  }


  if($werd_parts and scalar(@{$werd_parts})) {
    my $oldsyl = pop @{$werd_parts};
    _parse_werd($target, $oldsyl . $werd, $werd_account,
                $werd_parts, $variations, $oldsyl);
    return(${$variations});
  }
  else {
    return(${$variations});
  }
}

##########################################################################
#  Build a grammar from a passed in block of text
##########################################################################
sub build_grammar($;$$$) {

  require POSIX;
  import POSIX (qw/locale_h/);
  require locale;

  my $charset = "A-Za-z\xa0-\xbf\xc0-\xd6\xda-\xdd\xdf-\xf6\xf9-\xfd\xff'\\-";
  my (%account, $grammar, $index, $couldnts);

  my $obj = shift;

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my ($text, $appears_threshold, $follower_threshold, $locale) = @_;

  if($locale) {
    my $ret = setlocale("LC_CTYPE", $locale);
    if(!defined($ret)) {
      print STDERR "Could not load locale $locale: $!\n";
    }
  }

  if(_load_syllables($target) < 0) { return; }

  while($text =~ /[^$charset]*([$charset]+)[^$charset]*/sig) {
    my $werd = $1;
    $werd =~ s/^['\-]*//;
    $werd =~ s/['\-]*$//;
    if($werd eq "") { next; }

    my $werd_account = {};
    my $variations = _parse_werd($target, $werd, $werd_account);
    if($variations == 0) {
      push @{$couldnts}, $werd;
    }
    else {
      my $syllable;
      foreach $syllable (keys %{$werd_account}) {
        my $follower;
        foreach $follower (keys %{$werd_account->{$syllable}}) {
          $account{$syllable}{$follower}++;
        }
      }
    }
  }

  $grammar->[0][0] = "_BEGIN_";
  $index->{"_BEGIN_"} = 0;

  # Go through list and remove links that appear less than appears_threshold
  my $syllable;
  foreach $syllable (keys %account) {
    my $follower;
    foreach $follower (keys %{$account{$syllable}}) {
      if($account{$syllable}{$follower} < $appears_threshold) {
        delete $account{$syllable}{$follower};
      }
    }
  }

  my $syls_removed = 1;
  while($syls_removed) {
    $syls_removed = 0;

    foreach $syllable (keys %account) {

      my $explicit_keep = 0;
      my $linkcount = scalar(keys %{$account{$syllable}});

      # check for _END_ first, so good endings don't get removed
      my $follower;
      foreach $follower (keys %{$account{$syllable}}) {
        if($follower eq "_END_") { $explicit_keep = 1; }
      }
      if($explicit_keep) { next; }

      if($linkcount < $follower_threshold) {

        my $prior;
        # sub loop to remove links to this node
        foreach $prior (keys %account) {
          if($account{$prior}{$syllable}) {
            delete $account{$prior}{$syllable};
          }
        }

        delete $account{$syllable};
        $syls_removed = 1;
      }
    }
  }

  my $syllable_count;
  foreach $syllable (keys %account) {

    my $offset = $index->{$syllable};
    if(!defined($index->{$syllable})) {
      $syllable_count++;
      $grammar->[$syllable_count][0] = $syllable;
      $offset = $syllable_count;
      $index->{$syllable} = $offset;
    }

    my $follower;
    foreach $follower (keys %{$account{$syllable}}) {

      my $follower_offset = $index->{$follower};
      if(!$follower_offset) {
        $syllable_count++;
        $grammar->[$syllable_count][0] = $follower;
        $follower_offset = $syllable_count;
        $index->{$follower} = $follower_offset;
      }

      push @{$grammar->[$offset][1]}, \@{$grammar->[$follower_offset]};
      push @{$grammar->[$offset][2]}, $account{$syllable}{$follower};
    }
  }


  $target->{"grammar"} = $grammar;
  $target->{"index"} = $index;

  return($couldnts);
}


##########################################################################
#  Dump the current grammar to a user named file
##########################################################################
sub dump_grammar($) {
  my $obj = shift;

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  if(!$target->{"grammar"}) {
    bless $target; # a hack to get set_language to work
    $target->set_language("English");
  }

  my $grammar_out_file = shift;

  if(!Storable::nstore($target->{"grammar"}, $grammar_out_file)) {
    return -1;
  }

  return 0;
}

##########################################################################
#  Load in a user-specified grammar from an external file
##########################################################################
sub load_grammar_file($) {
  my $obj = shift;
  my $index_ref;

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $grammar_in_file = shift;

  my $grammar_ref = retrieve($grammar_in_file);
  if(!defined($grammar_ref)) { return -1; }

  my $count = scalar(@{$grammar_ref});

  for(my $i = 0; $i < $count; $i++) {
    $index_ref->{$grammar_ref->[$i][0]} = $i;
  }

  $target->{"grammar"} = $grammar_ref;
  $target->{"index"} = $index_ref;

  return 0;
}

##########################################################################
#  Load in a user-specified grammar from an external file
##########################################################################
sub load_syllable_file($) {
  my $obj = shift;
  my $indexed_syllables;

  my $target;
  if(ref $obj) { $target = $obj; }
  else { $target = $self; }

  my $syllable_file = shift;

  # Load the syllable list
  open SYLS, $syllable_file or return -1;
  chomp(my @syllables = );
  close SYLS;

  # Sort the list, but sorting longer words higher
  @syllables=sort { my $min=(length($a) < length($b)) ? length($a) : length($b);
            ( substr(lc($a),0,$min) cmp substr(lc($b),0,$min) ||
              length($b) <=> length($a) )
            } @syllables;

  # Remove duplicates (important for recursive parse)
  for(my $i = 1; $i < scalar(@syllables); $i++) {
    if(lc($syllables[$i]) eq lc($syllables[$i - 1])) {
      @syllables = splice(@syllables, $i, 1);
      $i--;
    }
  }

  my $syl;
  foreach $syl (@syllables) {
    $syl =~ /^((.).?)/;
    my $first = lc($2);
    my $firsttwo = lc($1);
    if($first eq $firsttwo) { $firsttwo = "_"; }
    push @{$indexed_syllables->{$first}{$firsttwo}}, $syl;
  }

  $target->{"syllables"} = $indexed_syllables;

  return 0;
}

1;

__END__