File Coverage

blib/lib/Lingua/Phonology/Rules.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#!/usr/bin/perl

package Lingua::Phonology::Rules;

=head1 NAME

Lingua::Phonology::Rules - a module for defining and applying
phonological rules.

=head1 SYNOPSIS

	use Lingua::Phonology;
	$phono = new Lingua::Phonology;

	$rules = $phono->rules;

	# Adding and manipulating rules is discussed in the "WRITING RULES"
	# section

=head1 DESCRIPTION

This module allows for the creation of linguistic rules, and the application of
those rules to "words" of Segment objects. You, the user, add rules to a Rules
object, defining various parameters and code references that actually perform
the action of the rule. Lingua::Phonology::Rules will take care of the guts of
applying and creating rules.

The rules you create may have the following parameters. This is just a brief
description of the parameters--a more detailed discussion of their effect is in
the L<"WRITING RULES"> section.

=over 4

=item * domain

Defines the domain within which the rule applies. This should be
the name of a feature in the featureset of the segments which the rule is
applied to.

=item * tier

Defines the tier on which the rule applies. Must be the name of a
feature in the feature set for the segments of the word you pass in.

=item * direction

Defines the direction that the rule applies in. Must be
either 'leftward' or 'rightward.' If no direction is given, defaults to
'rightward'.

=item * filter

Defines a filter for the segments that the rule applies on.
Must a code reference that returns a truth value.

=item * linguistic

Defines a linguistic-style rule to be parsed. When you provide a
linguistic-style rule, it is parsed into code references that take the place of
the C and C properties listed below. The format of linguistic rules
is described in L.

=item *

B - defines the condition or conditions where the rule applies. Must be a
coderef that returns a truth value. If no value is given, defaults to
always true.

=item *

B - defines the action to take when the C condition is met. Must be
a code reference. If no value is given, does nothing.

=back

Lingua::Phonology::Rules is flexible and powerful enough to handle any
sequential type of rule system. It cannot handle Optimality Theory-style
processes, because those require a fundamentally different kind of
algorithm.

=cut

use strict;
use warnings;
use warnings::register;
use Carp;
use Lingua::Phonology::Common;
use Lingua::Phonology::Word;
use Lingua::Phonology::Segment::Rules;
use Lingua::Phonology::Segment::Boundary;
use Lingua::Phonology::Segment::Tier;

our $VERSION = 0.3;

sub err ($) { _err($_[0]) if warnings::enabled() };

# This variable is created the first time someone tries to parse a lingustic
# rule, and reused thereafter
our $PARSER;

# Define valid properties for rules, name => default format. undef's for no default
our %property = (
	where => sub {1},
  	do	=> sub {},
	tier  => undef,
	filter => undef,
	result => undef,
	domain => undef,
	direction => 'rightward'
);

# Hash of property => validating coderef
our %valid = (
    where => sub { _is($_[0], 'CODE') },
    do => sub { _is($_[0], 'CODE') },
    result => sub { _is($_[0], 'CODE') },
    filter => sub { _is $_[0], 'CODE' },
    tier => sub {1},
    domain => sub {1},
    direction => sub { $_[0] = lc $_[0]; $_[0] eq 'rightward' || $_[0] eq 'leftward' }
);

# List of properties passed on to Lingua::Phonology::Word
our %worder = (
    filter => undef,
    tier => undef,
    domain => undef,
    direction => undef
);

for my $method (keys %worder) {
    no strict 'refs';
    *$method = sub {
        my $self = shift;
        my $rule = shift;
        return err "No such rule '$rule'" unless exists $self->{RULES}->{$rule};
        $self->{RULES}->{$rule}->{word}->$method(@_);
    }
}

# Additional arrays that list properties expecting code and text respectively
our @code = qw/where do filter result/;
our @text = qw/tier domain direction/;

# Build accessors for properties
foreach my $method (keys %valid) {
    next if exists $worder{$method};
    no strict 'refs';
    *$method = sub {
        my $self = shift;
        my $rule = shift;
        return err "No such rule '$rule'" unless exists $self->{RULES}->{$rule};
        if (@_) {
            # When defined, check for validity and add
            if (defined $_[0]) {
                if ($valid{$method}->($_[0])) {
                    $self->{RULES}->{$rule}->{$method} = $_[0];
                }
                else {
                    return err "Bad argument to $method()";
                }
            }
            # Otherwise, delete the key
            else {
                delete $self->{RULES}->{$rule}->{$method};
            }
        }
        return $self->{RULES}->{$rule}->{$method};
    };
}

# Constructor
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self = {
        RULES => { }, # list of rules
        ORDER => [ ], # rule order
        PERSIST => [ ], # list of persistent rules
        COUNT => 0, # count of times a rule applied, set by apply or apply_all
	};
	bless ($self, $class);
	return $self;
}

# Add a rule. Called as $rules->add_rule( Name => { ... } );
sub add_rule {
	my ($self, %rules) = @_;
	my $err = 0;

	RULE: for my $rule (keys(%rules)) {
        # Check rules or complain
        $self->_check_rule($rules{$rule}, $rule) or do {
            $err = 1;
            next RULE;
        };

        # Drop existing rules
        $self->drop_rule($rule);

        # Add new rules
        $self->_add_rule($rule, $rules{$rule});

	}
	return $err ? () : 1;
}

# Drop a rule
sub drop_rule {
    my $self = shift;
    delete $self->{RULES}->{$_} for @_;
    return scalar @_;
}

# Like add_rule, but check that the rule exists
sub change_rule {
    my ($self, %rules) = @_;
    my $err = 0;

    RULE: for my $rule (keys %rules) {
        # Complain when the rule doesn't exist
        if (not exists $self->{RULES}->{$rule}) {
            err("No such rule '$rule'");
            $err = 1;
            next RULE;
        }

        # Check rules
        $self->_check_rule($rules{$rule}, $rule) or do {
            $err = 1;
            next RULE;
        };

        # Add rules
        $self->_add_rule($rule, $rules{$rule});
    }
    return $err ? () : 1;
}

sub _check_rule {
    my ($self, $href, $name) = @_;
    # Parse ling rules
    if (exists $href->{linguistic}) {
        ($href->{where}, $href->{do}) = _parse_ling($href->{linguistic});
        unless ($href->{where} && $href->{do}) {
            return err "Couldn't parse linguistic rule for '$name'";
        }
        $href->{where} = _parse_ext($href->{where});
        $href->{do} = _parse_ext($href->{do});
    }

    # Validate keys
    for (keys %$href) {
        if (exists $valid{$_}) {
            unless ($valid{$_}->($href->{$_})) {
                return err("Invalid value for $_ in rule '$name'");
            }
        }
    }
    return 1;
}

sub _add_rule {
    my ($self, $rule, $href) = @_;

    $self->{RULES}->{$rule} = {};
    $self->{RULES}->{$rule}->{word} = Lingua::Phonology::Word->new();
    for (keys %property) {
        $self->$_($rule, $href->{$_} || $property{$_});
    }
}

sub clear {
	my $self = shift;
	$self->{RULES} = {};
	$self->{ORDER} = [];
	$self->{PERSIST} = [];
	return 1;
}

sub loadfile {
	my ($self, $file) = @_;

    # Calling loadfile() w/o a file loads a default, but there is no default
    # rule set. So do nothing and return true.
    return 1 if not defined $file;

    my $parse;
    eval { $parse = _parse_from_file($file, 'rules') };
    return err($@) if $@;
    $self->_load_from_struct($parse);
}

sub _load_from_struct {
    my ($self, $parse) = @_;
	my $err = 0;

	# Handle rule declarations
	RULE: for my $href (@{$parse->{rule}}) {
		my $parm = {};

        # If we ONLY have content, make it into a href
        if (not _is($href, 'HASH')) {
            $href = { content => $href };
        }

        # Take linguistic-style rules from the content
        if (exists $href->{content}) {
            # _parse_ling() returns where and do
			($href->{where}, $href->{do}) = _parse_ling($href->{content});
            unless ($href->{where} && $href->{do}) {
                err "Couldn't parse linguistic rule '$href->{name}'";
                $err = 1;
                next RULE;
            }
		}

		# Iterate over elements
        # code elements
        for (@code) {
            next if not exists $href->{$_};

            # If we ONLY have content
            if (not _is $href->{$_}, 'HASH') {
                $href->{$_} = { content => $href->{$_} };
            }

            if ((not exists $href->{$_}->{type}) || $href->{$_}->{type} ne 'plain') {
                eval { $parm->{$_} = _parse_ext $href->{$_}->{content} };
            }
            else {
                eval { $parm->{$_} = _parse_plain $href->{$_}->{content} };
            }

            # Always check $@ after parsing
            if ($@) {
                err("Error processing rule $href->{name}: $@\n");
                $err = 1;
                next RULE;
            }
        }
        # text elements
        for (@text) {
            next if not exists $href->{$_};
            $parm->{$_} = $href->{$_}->{value};
        }
        # Future types to be added here

		$self->add_rule($href->{name} => $parm) || do { $err = 1 };

	}

	# Handle ordering rules
	$self->order( map { [ map { $_->{name} } @{$_->{rule}} ] } @{$parse->{order}} );

	# Handle persistent rules
	$self->persist( map { $_->{name} } @{$parse->{persist}} );

	return $err ? () : 1;
}

sub _parse_ling {
	my $str = shift;

    if (not $PARSER) {
        require Lingua::Phonology::RuleParser;
        $PARSER = Lingua::Phonology::RuleParser->new();
    }

	my $parse = $PARSER->Rule($str);
	return if not $parse;
    return err "Unbalanced rule" unless @{$parse->{from}} == @{$parse->{to}};

	my (@do, @where); # Holds the statements built
	my $nulls = 0; # Counts the nulls encountered so far

    # Iterate over $parse->{from}, adding elements to @where and @do
	for my $i (0 .. $#{$parse->{from}}) {
        # The FROM item is not '__NULL': we have a real seg and need to make a test statement
		if ($parse->{from}[$i] ne '__NULL') {
			my $idx = $i - $nulls;
			push @where, _test_seg($idx, $parse->{from}[$i]);
			push @do, _set_seg($idx, $parse->{to}[$i]);
		}
        # The FROM item is '__NULL'--insert a segment
		elsif ($parse->{from}[$i] eq '__NULL') {
			push @do, _insert_seg($i - $nulls, $parse->{to}[$i]);
			$nulls++;
		}
	}

    # Special case for when we ONLY have nulls in FROM and the next segment is
    # a boundary. Normally this would generate a $_[0]->BOUNDARY statement, but
    # that can never succeed, so we roll focus back one seg.
    my $backstep = 0;
    if ($nulls == @{$parse->{from}}) {
        foreach (@{$parse->{when}}) {
            if ($_->[1][0] eq '__BOUNDARY') {
                # Redact the existing statements
                foreach (@do) {
                    s/\[(-?\d+)\]/\[$1 + 1\]/g;
                }
                $backstep = 1;
                last;
            }
        }
    }

	# Build the strings based on the "when" property
	my @conds;
	for my $cond (@{$parse->{when}}) {
        my @thiscond;
        # The pre '_' segments are in [0], go through them backwards
        for (my $i = -1; $i >= -@{$cond->[0]}; $i--) {
            push @thiscond, _test_seg($i + $backstep, $cond->[0][$i]);
        }
        # The post '_' statements are in $cond->[1].
        for my $i (0 .. $#{$cond->[1]}) {
            my $idx = $i + $backstep + scalar @{$parse->{from}} - $nulls;
            push @thiscond, _test_seg($idx, $cond->[1][$i]);
        }
        push @conds, '(' . join(' && ', @thiscond) . ')';
    }
	push @where, '(' . join(' || ', @conds) . ')' if @conds;

    # Final joins - return (where, do)
    return join(" && ", @where), join("\n", @do);
}

# Segs should be an array ref, a hash ref, '__BOUNDARY', or a string
sub _test_seg {
    my ($i, $seg) = @_;
    if (ref $seg eq 'ARRAY') {
        return '(' . join(' || ', map { _test_seg($i, $_) } @$seg) . ')';
    }
    elsif (ref $seg eq 'HASH') {
        # Special case for empty hash - corresponds to "[]" in input, which we
        # want to be always true, instead of compiling to "()", which would be
        # always false
        return 1 if not keys %$seg;

		# General case
		return '(' . join(' && ', map { _test_feature($i, $_, $seg->{$_}) } keys %$seg) . ')';
	}
	elsif ($seg eq '__BOUNDARY') {
		return "(\$_[$i]->BOUNDARY)";
	}
	else {
		$seg = quotemeta $seg;
		return "(\$_[$i]->spell eq \"$seg\")";
	}
}

# Set seg cannot take an array ref, otherwise the same as _test_seg.
sub _set_seg {
	my ($i, $seg) = @_;
	if (ref $seg eq 'HASH') {
		return join "\n", map { _set_feature($i, $_, $seg->{$_}) } keys %$seg;
	}
	elsif ($seg eq '__NULL') {
		return "\$_[$i]->DELETE;\n";
	}
	else {
		return "Lingua::Phonology::Functions::change(\$_[$i], \"$seg\");\n";
	}
}

# Features should be '__TRUE', '__FALSE', a number, or a string
sub _test_feature {
	my ($i, $feat, $val) = @_;
    no warnings 'numeric';

	if ($val eq '__TRUE') {
		return "(\$_[$i]->value(\"$feat\"))";
	}
	elsif ($val eq '__FALSE') {
		return "(not \$_[$i]->value(\"$feat\"))";
	}
	elsif ($val eq int $val) {
		return "(\$_[$i]->value(\"$feat\") == $val)";
	}
	else {
		return "(\$_[$i]->value(\"$feat\") eq \"$val\")";
	}
}

sub _set_feature {
	my ($i, $feat, $val) = @_;
    no warnings 'numeric';

	$val = 1 if $val eq '__TRUE';
	if ($val eq '__FALSE') {
		return "\$_[$i]->delink(\"$feat\");";
	}
	elsif ($val eq int $val) {
		return "\$_[$i]->value(\"$feat\", $val);";
	}
	else {
		return "\$_[$i]->value(\"$feat\", \"$val\");";
	}
}

sub _insert_seg {
	my ($i, $seg) = @_;
    # Make an unlikely-to-repeat variable name
    my $var = sprintf "\$new%06d", rand(1_000_000);
    # Take the new segment from $_[+0], which won't be touched by backstepping
	my $rv = "my $var = \$_[+0]->new;\n";
    # Do a normal _set_seg w/ '~' placeholder and then s/// the result
	$rv .= _set_seg('~', $seg);
	$rv =~ s/\$_\[~\]/$var/g;

	$rv .= "\$_[$i]->INSERT_LEFT($var);\n";
	return $rv;
}

sub _to_str {
	my ($self, $file) = @_;

	require B::Deparse;
	my $dpar = B::Deparse->new('-x7', '-p', '-si6');
    $dpar->ambient_pragmas(strict => 'all', warnings => 'all');

	# Hashref structure
	my $href = { rule => {}, order => { block => [] }, persist => [] } ;

	# Construct href entries for rules
	for my $rule (keys %{$self->{RULES}}) {
        # Add our name
		for (@text) {
			$href->{rule}->{$rule}->{$_} = { value => $self->$_($rule) }
                if defined $self->$_($rule);
		}
		for (@code) {
			next if not defined $self->$_($rule);
            my $str = _deparse_ext $self->$_($rule), $dpar or err($@);
			$href->{rule}->{$rule}->{$_} = [ $str . '    ' ]; # Extra whitespace to help alignment
		}
	}

	# Href entries for order and persist
	$href->{order}->{block} = [ map { { rule => [ map { { name => $_ } } @$_ ] } } $self->order ];
	$href->{persist} = { rule => [ map { { name => $_ } } $self->persist ] };

	return eval { _string_from_struct({ rules => $href }) };
}

sub apply {
	my ($self, $rule, $orig) = @_;

	return err("No such rule '$rule'") unless exists $self->{RULES}->{$rule};
    return err "Argument not an array reference" unless _is $orig, 'ARRAY';

    # Get the word
    my ($word, $where, $do, $result)
        = @{$self->{RULES}->{$rule}}{('word', 'where', 'do', 'result')};

    # Attempt to set this to the word
    $word->set_segs(@$orig) || return err($@);
    $word->rule({ map { $_ => $self->$_($rule) } keys %property });

	# Reset the counter
	$self->{COUNT} = 0;

    # Iterate over the segments
    while ($word->next) {
        my @word = $word->get_working_segs;
        if ($where->(@word)) {
            # Apply the rule
            $do->(@word);
            $self->{COUNT}++;
        }
    }

	@$orig = $word->get_orig_segs;
    $word->clear; # Free up memory

	return @$orig;
}

# Makes rules appliable by their name
our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;
	my $method = $AUTOLOAD;
	$method =~ s/.*:://;

	# For calling rules by name
	if ($self->{RULES}->{$method}) {
		# Compile functions which are rules
        no strict 'refs';
        *$method = sub {
			my ($self, $word) = @_;
			$self->apply($method, $word);
        };

		# Go to the rule
		return $self->$method(@_);
	}
    die "No such method: $AUTOLOAD, called";
}

sub DESTROY {
	$_[0]->clear;
}

sub apply_all {
	my ($self, $word) = @_;
	my %count = ();

	my @persist = $self->persist; # Only get this once, for speed
	for ($self->order) {
		for (@persist) {
			$self->apply($_, $word);
			$count{$_} += $self->{COUNT};
		}
		for (@$_) {
			$self->apply($_, $word);
			$count{$_} += $self->{COUNT};
		}
	}
	for (@persist) {
		$self->apply($_, $word);
		$count{$_} += $self->{COUNT};
	}

	# Set COUNT to be the hashref
	$self->{COUNT} = \%count;

}

sub order {
	my ($self, @items) = @_;
	foreach (@items) {
		$_ = [ $_ ] if not ref $_;
	}
	$self->{ORDER} = \@items if @items;
	return @{$self->{ORDER}};
}

sub persist {
	my $self = shift;
	$self->{PERSIST} = \@_ if @_;
	return @{$self->{PERSIST}};
}

sub count {
	return $_[0]->{COUNT};
}

1;

__END__