File Coverage

blib/lib/Lingua/Awkwords/Subpattern.pm

Criterion	Covered	Total	%
statement	45	45	100.0
branch	11	12	91.6
condition	4	5	80.0
subroutine	11	11	100.0
pod	6	6	100.0
total	77	79	97.4

# -*- Perl -*-
#
# subpatterns are named A-Z and offer short-hand notation for e.g. V =>
# a/e/i/o/u (or instead a reference to some other parse tree)

package Lingua::Awkwords::Subpattern;

use strict;
use warnings;
use Carp qw(confess croak);
use Moo;
use namespace::clean;

our $VERSION = '0.08';

# these defaults set from what the online version does at
# http://akana.conlang.org/tools/awkwords/
my %patterns = (
    C => [qw/p t k s m n/],
    N => [qw/m n/],
    V => [qw/a i u/],
);

has pattern => (
    is      => 'rw',
    trigger => sub {
        my ( $self, $pat ) = @_;
        die "subpattern $pat does not exist" unless exists $patterns{$pat};
        $self->_set_target( $patterns{$pat} );
    },
);
has target => ( is => 'rwp', );

########################################################################
#
# METHODS

sub get_patterns {
    return %patterns;
}

sub is_pattern {
    my ( undef, $pat ) = @_;
    return exists $patterns{$pat};
}

sub render {
    my ($self) = @_;

    my $ret;
    my $target = $self->target;
    my $type   = ref $target;

    # this complication allows for subpatterns to point at other parse
    # trees instead of just simple terminal strings (yes, you could
    # create loops where a ->render points to itself (don't do that))
    #
    # NOTE walk sub must be kept in sync with this logic
    if ( !$type ) {
        $ret = $target;
    } else {
        if ( $type eq 'ARRAY' ) {
            # do not need Math::Random::Discrete here as the weights are
            # always equal; for weighted instead write that unit out
            # manually via [a*2/e/i/o/u] or such
            $ret = @{$target}[ rand @$target ] // '';
        } else {
            $ret = $target->render;
        }
    }
    return $ret;
}

sub set_patterns {
    my $class_or_self = shift;
    # TODO error checking here may be beneficial if callers are in the
    # habit of passing in data that blows up on ->render or ->walk
    %patterns = ( %patterns, @_ );
    return $class_or_self;
}

sub update_pattern {
    my $class_or_self = shift;
    my $pattern       = shift;

    # TODO more error checking here may be beneficial if callers are in
    # the habit of passing in data that blows up on ->render
    croak "update needs a pattern and a list of values\n" unless @_;
    croak "value must be defined" if !defined $_[0];

    # NOTE arrayref as single argument is saved without making a copy of
    # the contents; this will allow the caller to potentially change
    # that ref and thus influence what is stored in patterns after this
    # update_pattern call
    $patterns{$pattern} = @_ == 1 ? $_[0] : [@_];

    return $class_or_self;
}

sub walk {
    my ( $self, $callback ) = @_;

    $callback->($self);

    my $target = $self->target;
    my $type   = ref $target;

    # NOTE this logic must be kept in sync with render sub
    if ( $type and $type ne 'ARRAY' ) {
        $target->walk($callback);
    }
    return;
}

1;
__END__