view release on metacpan or  search on metacpan

lib/Lingua/Awkwords/Subpattern.pm  view on Meta::CPAN

);

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__

=head1 NAME

Lingua::Awkwords::Subpattern - implements named subpatterns

=head1 SYNOPSIS

  use feature qw(say);
  use Lingua::Awkwords;
  use Lingua::Awkwords::Subpattern;

  # pick-one-of-these patterns (equal weights)
  Lingua::Awkwords::Subpattern->set_patterns(
      C => [qw/p t k s m n/],
      N => [qw/m n/],
      V => [qw/a i u/],
  );

  my $triphthong = Lingua::Awkwords->new( pattern => q{ VVV } );
  say $triphthong->render;

  # patterns can also point to parse trees
  Lingua::Awkwords::Subpattern->update_pattern(
      T => $triphthong
  );