#!perl

package Derive;

=head1 Derive

B<Derive> runs a sequential list of sound change rules against a test
suite.  E.g., you could input a list of sound changes that
Proto-Indo-European words are hypothesized to have undergone on the
way to Proto-Germanic; input pairs of PIE and PG words; then see if
the rules will correctly change the PIE words into the PG words.
After each rule, if there is a change, B<Derive> will print out the new
form and the name of the rule.

Intended usage is for the user to declare a new class that inherits
from B<Derive.>  The new class must define an I<inventory> method, which
tells what sound segments are legal, telling their spelling and the
features they contain; a I<rules> method, which lists the names of the
rules and the order in which they apply; a Perl function for each
rule; and a I<test_suite> method, which returns a list of before and
after word pairs.  One could then run the system by calling
MyClass->new->test.

The file F<IE_to_PG.pl> proves an example of how the system is used.

=head2 inventory

The I<inventory> method defines the spellings and the features they
represent.  There is no predefined meaning to any of the letters, nor
are there any predefined features.  The spellings can be any arbitrary
strings not including spaces---in particular, they may be more than
one character in length---but the following characters should be
avoided unless one does some serious tinkering with the system: {} <>
$ You may also wish to take into consideration that the system uses
Perl regular expressions, so if you use any pattern-matching symbol
such as . ^ | * + ? ( ) @ [ - ] \ you may end up doing a lot of
backslashing in your regexps.  Spellings that start with a digit could
also confuse the system, because spellings appear throughout inside {}
braces. (Possibly this was a mistake.)  On the other hand, the
following should be safe: any letter, upper and lower case; probably
0-9 if combined with some other character besides a comma; any
character with the 8th bit on; and ~ ` ! # % & = : ; ' " , / The
spellings may be any length.  Ambiguities may result.  Consider, for
example, that the spellings I<k>, I<w>, and I<kw> are all defined:
then in parsing I<kwis> it is not clear whether the first two letters
are a sequence of I<k> plus I<w>, or the digraph I<kw>.  When reading
input words, B<Derive> will always assume the longest string is
correct.

Each line of the inventory defines a new sound segment.  The first
element on the line is the spelling.  Then comes white space, followed
by the names of the features that the spelling represents.  Each
feature name is separated by white space, and can otherwise contain
any Latin-1 character.  Sounds are treated as unstructured bundles of
features: B<Derive> doesn't do any clever hierarchical organization,
defaults, etc.  A sound is held to have the value + for all the
features listed on the line, and - for all other features mentioned on
other lines of the inventory.

B<Derive> requires that you define sound segments for all words used
in the test suite for the parent language and for the child language.
In addition, you must define sound segments for all intermediate
forms. This permits B<Derive> to actually print out the intermediate
forms, and lets it raise an error as soon as some nonsensical sound is
produced.

Example:

g  C obstr stop vel voiced
x  C obstr fric vel
G  C obstr fric vel voiced
gh C obstr stop vel voiced asp
N  C son   nas  vel voiced
kw C obstr stop labiovel
gw C obstr stop labiovel voiced

=head2 rules

The I<rules> method returns a reference to a list of method names.
Each method is considered a description of a sound change, as
discussed below.  This method tells what those rules are, and what
order they apply in.  Note that because these are method names, they
do not take any package specification.

Example:

sub rules {[qw{
  Vocalize_Interconsonantal_Laryngeals
  Delete_Laryngeals
  Depalatalize_Stops
}]}

=head2 rule methods

The rules themselves are simply Perl methods defined on the class that
you have created.  Basically all they do is look at the 'form'
hashtable entry in the current instance of that class (as passed in as
the 1st and only argument, or taken from the global variable
$Derive::system) and potentially alter it.  The 'form' is a string
representing the linguistic form under consideration, with each
sound's spelling enclosed in {} brackets; e.g., /kwis/ might be
represented as "{kw}{i}{s}".

Generally speaking, however, one will want to make use of the helper
function I<Change>.  I<Change> is similar to Perl's I<s> operator, but
with lots of extra functionality to assist in the task.  I<Change>
takes two string arguments, the first a regexp telling what the rule
matches, the second telling what to change it to.  In the simplest case:

Change q{ {e} } =>
       q{ {i} };

The first string may contain any Perl regexp code.  It may also
contain feature specifications that match particular sets of sounds.
Such specifications are enclosed in < > brackets.  Inside the
specification are the names of features (case sensitive).  Each may be
preceded by a - which flips the value (i.e., -long would be all sounds
that do not have the feature I<long>), or an optional + which does
nothing.  They may be separated by the operators I<,> (or its synonym
I<&>), which says that the sound to be matched must contain the
features on both the right B<and> left side; or I<|>, which says that
the sound must contain either the left B<or> right side feature, or
both.  Parentheses should be used to disambiguate ambiguous series of
three or more (the default is left association for all binary
operators).  Parenthetically grouped lists may also be preceded by
negative I<->.

The second string tells what to subsitute for the material matched by
the first pattern if it is found within $Define::system->{form}. If
parentheses are grouped around material in the first pattern, then $1,
$2, etc. refer to the text matched within the first, second, etc.,
sets of parentheses.  One may also group the $ variables within < >
brackets qualified by a following list, in parentheses, of feature
values to be added to or subtracted from the matched segment.  For
example, <$1(-asp, -stop, +fric)> would interpolate whatever is
matched by the first group of parentheses, except that the features
I<asp> and I<stop>, if any, will be removed, and the feature I<fric>
will be added.  The spelling that corresponds to that feature
description is added; it must have been one of the sounds listed in
the inventory.  The I<+> sign is optional.

I<Change> returns the number of times that the rule applied in the string.

The following example implements part of Grimm's Law:

Change q{ (^ | <-obstr>)  (<stop, -voiced>) } =>
       q{     $1         <$2(-stop, +fric)> };

The first parenthesized expression in the first string matches the
beginning of the form, or any sound that does not have the feature
I<obstr>.  The second matches any sound that has the feature I<stop>
but not the feature I<voiced>.  If that sequence is found, it is
replaced by whatever the first parenthesis matched --- i.e., there is
no change there --- followed by whatever the second parenthesis
matched, but subtituting the sound that is equivalent except that it
does not have the gfeature I<stop> but does have the feature I<fric>.
Note that spaces have no meaning and can be used freely for
readability.  They do not even function as token delimiters, and could
even appear in the middle of the name of a feature, e.g., I<stop> and
I<st op> are equivalent.

=head2 test_suite

The I<test_suite> method gives a list of forms to be run through the
rule set, as well the forms they should be turned into.  B<Derive>
will test to see whether the rule set does indeed give the predicted
result.

The method should return a reference to a list of tests.  Each test is
a reference to a list that contains: a string that represents the original historical form; a string that represents the form it should turn into; and an optional gloss string, e.g.:

sub test_suite {[
  ["akwja:'"    => "a'wjo:",     'island'],
  ["kupna:'"    => "hu'ppo:"]
];}

Note that {} are not used to delimit sounds; a separate parsing method
takes care of adding the brackets.

=head2 Usage

With those methods in place, you use the system by first defining an
object of your class:

my $thing = My_Class->new;

Then you can run the test suite by invoking:

$thing->test;

If you just want to try out a form at a time, you can feed it into the
method I<run_rules>.  That expects a form already parsed into {}
notation.  If you have an unparsed form, you can feed that through the
I<parse> method:

my $output = $thing->run_rules($thing->parse("jugom"));


=cut

use strict;
use integer;
use Exporter();
@Derive::ISA = qw{Exporter};

@Derive::EXPORT = qw{system Change};

#The Derive object that is currently running:
my $system;

sub get_fvector_from_letter {
  my($self, $segment) = @_;
  $segment =~ s{[{}]}{}g;
  my $v = $self->{letter_to_feature_vector}->{$segment};
  if (!defined($v)) {
    die("Don't have a feature vector for letter |$segment|");
  }
  $v;
}

sub parse_feats_descr {
  my($self, $descr) = @_;
  my $list = [];
  my $sign;
  while (1) {
    if ($descr =~ m{\G $}gcx) {return $list;}
    if ($descr =~ m{\G \s+ }gcx) {redo;}
    if ($descr =~ m{\G , }gcx) {redo;}
    if ($descr =~ m{\G ([+-]) }gcx) {
      if (defined($sign)) {die "Can't have two signs in a row: $sign$1"}
      $sign = $1;
      redo;
    }
    if ($descr =~ m{\G ([^\s+,-]+) }gcx) {
      my $name = $1;
      my $feat = $self->{feature_name_to_number}->{$name};
      if (!defined($feat)) {
        die("Don't recognize feature '$name'\n");
      }
      if (!defined($sign)) {$sign = '+'}
      my $val = ($sign eq '+') ? 1 : 0;
      push(@$list, [$val, $feat]);
      $sign = undef;
      redo;
    }
    die "Don't understand syntax: $descr";
  }
}

sub update_fvector {
  my($self, $fvector, $fspec) = @_;
  #print("Update_FVector($fvector, $fspec)\n");
  foreach my $spec (@$fspec) {
    #print "$spec->[0] $spec->[1]\n";
    vec($fvector, $spec->[1], 1) = $spec->[0];
  }
  $fvector;
}

sub letter_from_fvector($) {
  my($self, $vec) = @_;
  my $letter = $self->{feature_vector_to_letter}->{$vec};
  if (!defined($letter)) {
    warn("Feature vector does not match any letter:\n");
    while (my($name, $num) = each %{$self->{feature_name_to_number}}) {
      if (vec($vec, $num, 1)) {warn("  $name\n");}
    }
    die;
  }
  "{$letter}";
}

sub postchange {
  my($self, $args) = @_;
  #print("postchange($args)\n");
  my $segment;
  my $incr_feats;
  if ($args =~ m{^([^(]*) \( ([^)]*) \)$}x) {
    $segment = $1;
    $incr_feats = $2;
  } else {
    die "Unrecognized exchange: |$args|\n";
  }
  #print(" |$segment|, |$incr_feats|\n");
  #At the moment we'll assume we're only dealing with a single segment
  my $old_vec = $self->get_fvector_from_letter($segment);
  my $incr_feats_parsed = $self->parse_feats_descr($incr_feats);
  $old_vec = $self->update_fvector($old_vec, $incr_feats_parsed);
  $self->letter_from_fvector($old_vec);
}

sub Change($$) {
  my($old, $new) = @_;
  my $self = $system;
  #print("Change |$old| => |$new|\n");
  if ($self->ignore_space) {
    $old =~ s{\s+}{}g;
    $new =~ s{\s+}{}g;
  }
  $old =~ s{<([^>]+)>}{$self->interpret_fd($1)}eg;
  $new = "\"$new\"";
  $new =~ s{\$(\d+)}{\${$1}}g;
  $new =~ s{< ([^>]*) >}
           {" . \$self->postchange("$1") . "}gx;
  my $modifiers = 'eg';
  my $ev = "\$self->{form} =~ s{$old}{$new}$modifiers;";
  #print "eval($ev)\n";
  my $n_changes = eval($ev);
  if ($@) {
    die("eval of \"$ev\" failed:\n$@\n");
  }
  #print "-> $form\n";
  return($n_changes);
}

sub new {
  my($type) = @_;
  my $self = {};
  bless($self, $type);
  $self->initialize;
  $self;
}

sub ignore_space {1}

sub inventory {
  die("You haven't defined your phonetic inventory.\n");
}

sub rules {
  die("You haven't defined your rules.\n");
}

sub initialize_features {
  my($self) = @_;
  my $n_features = 0;
  my $feature_name_to_number = {};
  foreach my $line (@{$self->{inv}}) {
    my $letter = $line->{letter};
    my $feature_names = $line->{feature_names};
    foreach my $f (@$feature_names) {
      if (!exists($feature_name_to_number->{$f})) {
        $feature_name_to_number->{$f} = $n_features++;
      }
    }
  }
  $self->{n_features} = $n_features;
  $self->{feature_name_to_number} = $feature_name_to_number;
}

sub N_Bytes_Needed {
  my($n_bits) = @_;
  int(($n_bits - 1) / 8) + 1;
}

sub initialize_letters {
  my($self) = @_;
  $self->{n_letters} = scalar(@{$self->{inv}});
  my $letter_to_feature_vector = $self->{letter_to_feature_vector} = {};
  my $feature_vector_to_letter = $self->{feature_vector_to_letter} = {};
  my $feature_to_letter_vector = $self->{feature_to_letter_vector} = {};
  my $number_to_quoted_letter = $self->{number_to_quoted_letter} = [];
  my $empty_letter_vector = "\x00" x N_Bytes_Needed($self->{n_letters});
  my $empty_feature_vector = "\x00" x N_Bytes_Needed($self->{n_features});
  my $letter_number = 0;
  foreach my $line (@{$self->{inv}}) {
    my $letter = $line->{letter};
    if ($letter =~ m{([<>{}\$])}) {
      die("$1 is a reserved character\n");
    }
    my $feature_names = $line->{feature_names};
    my $quoted = $line->{quoted_letter} = quotemeta($letter);
    if (exists($letter_to_feature_vector->{$letter})) {
      die("Letter /$letter/ defined multiple times\n");
    }
    $number_to_quoted_letter->[$letter_number] = $quoted;
    my $v = $empty_feature_vector;
    foreach my $f (@$feature_names) {
      my $old = $feature_to_letter_vector->{$f};
      if (!defined($old)) {$old = $empty_letter_vector;}
      vec($old, $letter_number, 1) = 1;
      $feature_to_letter_vector->{$f} = $old;
      vec($v, $self->{feature_name_to_number}->{$f}, 1) = 1;
    }
    $feature_vector_to_letter->{$v} = $letter;
    $letter_to_feature_vector->{$letter} = $v;
    $letter_number++;
  }  
}

sub by_descending_length {
  my $cmp = $b->[1] <=> $a->[1];
  if (!$cmp) {$a cmp $b}
  else {$cmp}
}

sub initialize_word_parser {
  my($self) = @_;
  my @notations = ();
  foreach my $line (@{$self->{inv}}) {
    #print "$line->{quoted_letter}\n";
    push(@notations, [$line->{quoted_letter}, length($line->{quoted_letter})]);
  }
  @notations = sort by_descending_length @notations;
  my $parser_string = '';
  foreach my $notation_rec (@notations) {
    my $notation = $notation_rec->[0];
    $parser_string .= "|$notation";
  }
  $parser_string =~ s{^\|}{\^\(};
  $parser_string .= ')';
  my $word_parser_code = <<"END";
sub {
  my(\$str) = \@_;
  if (!\$str) {return undef;}
  if (\$str =~ m{$parser_string}) {
    return \$1;
  }
  die("Misunderstood character in string: \\"\$str\\"");
}
END
  $self->{word_parser} = eval($word_parser_code);
  if ($@) {
    die("Couldn't eval word_parser code:\n$@\n$word_parser_code");
  }
}

sub parse_inventory {
  my($self) = @_;
  my $inventory = $self->inventory;
  $inventory =~ s{^[\n\r]+}{};
  my @arr = split(m{[\n\r]+}, $inventory);
  if (!scalar(@arr)) {
    die("Empty inventory\n");
  }
  my $inv = [];
  foreach my $line (@arr) {
    #print "$line\n";
    my($letter, @feature_names) = split(m{\s+}, $line);
    push(@$inv, {letter => $letter, feature_names => [@feature_names]});
  }
  $self->{inv} = $inv;
}

sub initialize {
  my($self) = @_;
  $self->parse_inventory;
  $self->initialize_features;
  $self->initialize_letters;
  $self->initialize_word_parser;
  delete($self->{inv});
}

sub parse {
  my($self, $in) = @_;
  my $full = $in;
  my @out = ();
  while ($in) {
    my $ph = eval { $self->{word_parser}->($in); };
    if ($@) {
      die("Error parsing input form '$full':\n$@");
    }
    push(@out, $ph);
    $in = substr($in, length($ph));
  }
  '{' . join('}{', @out) . '}';
}

sub run_rules {
  my($self, $forms) = @_;
  $system = $self;
  $self->{form} = undef;
  my $error = 0;
  foreach my $rule (@{$self->rules}) {
    if ($rule =~ m{^\s*<([^>]+)>\s*$}) {
      my $stage = $1;
      if (defined($self->{form})) {
        print("$stage\n");
        if (defined($forms->{$stage})) {
	  my $deparsed = $self->{form};
	  $deparsed =~ s{[{}]}{}g;
	  if ($deparsed ne $forms->{$stage}) {
	    print("***Error: expected $stage form is $forms->{$stage}\n");
	  }
        }
      } elsif (defined($forms->{$stage})) {
        $self->{form} = $self->parse($forms->{$stage});
        print("$stage\n$self->{form}\n");
      }
      next;
    }
    if (!defined($self->{form})) {next;}
    my $old = $self->{form};
    eval("\$self->$rule;");
    if ($@) {
      die("Failure in executing rule $rule:\n$@");
    }
    if ($self->{form} ne $old) {
      printf("%-30s $rule\n", $self->{form});
    }
  }
  $error;
}

sub Percent {
  my($num, $denom) = @_;
  no integer;
  sprintf("%6.2f", ($num / $denom) * 100);
}

sub test {
  my($self) = @_;
  my $n_errors = 0;
  my $n_all = 0;
  foreach my $test (@{$self->test_suite}) {
    $n_all++;
    if (defined($test->{gloss})) {
      print "'$test->{gloss}':\n";
    }
    $n_errors += $self->run_rules($test);
    print("\n");
  }
  my $percent = Percent($n_all - $n_errors, $n_all);
  printf("%d errors, $percent%% correct.\n", $n_errors);
}


sub feature_name_to_vector {
  my($self, $feature_name) = @_;
  my $vector = $self->{feature_to_letter_vector}->{$feature_name};
  if (!defined($vector)) {
    die("Feature name not recognized: '$feature_name'");
  }
  $vector;
}

sub and {
  my($self, $v1, $v2) = @_;
  my $new = $v1 & $v2;
  if ($new =~ m{^\0+$}) {
    die("Combining features with & results in empty set");
  }
  $new;
}

sub or {
  my($self, $v1, $v2) = @_;
  $v1 | $v2;
}

sub apply_binary {
  my($self, $op, $v1, $v2) = @_;
  if ($op eq '&') {
    return $self->and($v1, $v2);
  } elsif ($op eq '|') {
    return $self->or($v1, $v2);
  }
}

sub apply_unary {
  my($self, $op, $v) = @_;
  if ($op eq '-') {
    return ~$v;
  }
}

sub push_vector {
  my($self, $vector) = @_;
  my $tokens = $self->{tokens};
  if (!@$tokens) {push(@$tokens, ['vector', $vector]); return;}
  my $prev_type = $tokens->[scalar(@$tokens) - 1]->[0];
  if ($prev_type eq 'openg') {push(@$tokens, ['vector', $vector]); return;}
  my $prev = pop(@$tokens);
  my $new;
  if ($prev_type eq 'vector') {
    push(@$tokens, ['vector', $self->and($prev->[1])]);
  } elsif ($prev_type eq 'unary') {
    $self->push_vector($self->apply_unary($prev->[1], $vector));
  } elsif ($prev_type eq 'binary') {
    my $prev_prev = pop(@$tokens);
    push(@$tokens, 
      ['vector', $self->apply_binary($prev->[1], $prev_prev->[1], $vector)]);
  }
}

sub push_feature {
  my($self, $feature_name) = @_;
  my $vector = $self->feature_name_to_vector($feature_name);
  $self->push_vector($vector);
}

sub finish_spec {
  my($self) = @_;
  my $tokens = $self->{tokens};
  if (scalar(@$tokens) != 1 or $tokens->[0]->[0] ne 'vector') {
    die("Misunderstood segment spec\n");
  }
}

sub push_binary_operator {
  my($self, $op) = @_;
  my $tokens = $self->{tokens};
  if (!@$tokens) {die "$op operator illegal at start of expression"}
  my $prev_type = $tokens->[scalar(@$tokens) - 1]->[0];
  if ($prev_type ne 'vector') {
    die("$op operator illegal after $prev_type token");
  }
  push(@$tokens, ['binary', ($op =~ m{[,&]}) ? '&' : '|']); 
}

sub push_unary_operator {
  my($self, $op) = @_;
  my $tokens = $self->{tokens};
  if (@$tokens) {
    my $prev_type = $tokens->[scalar(@$tokens) - 1]->[0];
    if ($prev_type eq 'vector') {
      push(@$tokens, ['binary', '&']);
    } elsif ($prev_type eq 'unary') {
      die("Two - in a row are illegal");
    }
  }
  push(@$tokens, ['unary', '-']); 
}

sub push_open_group {
  my($self) = @_;
  my $tokens = $self->{tokens};
  if (@$tokens) {
    my $prev_type = $tokens->[scalar(@$tokens) - 1]->[0];
    if ($prev_type eq 'vector') {
      push(@$tokens, ['binary', '&']);
    }
  }
  push(@$tokens, ['openg']);
}

sub close_group {
  my($self) = @_;
  my $tokens = $self->{tokens};
  if (!@$tokens) {die ") is illegal at start of expression"}
  my $vector = pop(@$tokens);
  if ($vector->[0] ne 'vector') {
    die(") is illegal after $vector->[0] token");
  }
  my $openg = pop(@$tokens);
  if ($openg->[0] ne 'openg') {
    die(") is not preceded by a matching (");
  }
  $self->push_vector($vector->[1]);
}

sub fspec_to_vector {
  my($self, $fspec) = @_;
  #print("fspec_to_vector($fspec):\n");
  $self->{tokens} = [];
  while (1) {
    if ($fspec =~ m{\G $ }gcx) {
      $self->finish_spec;
      last;
    }
    if ($fspec =~ m{\G \s+ }gcx) {redo}
    if ($fspec =~ m{\G \+ }gcx) {redo}
    if ($fspec =~ m{\G ([,&]) }gcx) {
      $self->push_binary_operator($1);
      redo;
    }
    if ($fspec =~ m{\G \| }gcx)   {
      $self->push_binary_operator('|');
      redo;
    }
    if ($fspec =~ m{\G - }gcx)    {
      $self->push_unary_operator('-');
      redo;
    }
    if ($fspec =~ m{\G \( }gcx) {
      $self->push_open_group;
      redo;
    }
    if ($fspec =~ m{\G \) }gcx) {
      $self->close_group;
      redo;
    }
    if ($fspec =~ m{\G ([^\s,&;|()+-]+) }gcx) {
      #Should be a feature name:
      $self->push_feature($1);
      redo;
    }
  }
  my $v = $self->{tokens}->[0]->[1];
  delete($self->{tokens});
  return $v;
}

sub vector_to_pattern {
  my($self, $vector) = @_;
  #print("vector_to_pattern($vector)\n");
  my @parts = ();
  my $n_letters = $self->{n_letters};
  for (my $p = 0; $p < $n_letters; $p++) {
    if (vec($vector, $p, 1)) {
      push(@parts, $self->{number_to_quoted_letter}->[$p]);
    }
  }
  my $str = '(?:\{(?:' . join('|', @parts) . ')\})';
  #print "  $str\n";
  $str;
}

sub parse_feature_spec {
  my($self, $fspec) = @_;
  my $vector = $self->fspec_to_vector($fspec);
  $self->vector_to_pattern($vector);
}

sub interpret_fd {
  my($self, $key) = @_;
  my $cached = $self->{cache}->{$key};
  if (defined($cached)) {return $cached}
  my $pattern = eval {$self->parse_feature_spec($key);};
  if ($@) {
    die("Couldn't parse \$s{$key}:\n$@");
  }
  $self->{cache}->{$key} = $pattern;
}

1;