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


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # subpatterns are named A-Z and offer short-hand notation for e.g. V =>
4             # a/e/i/o/u (or instead a reference to some other parse tree)
5              
6             package Lingua::Awkwords::Subpattern;
7              
8 4     4   98774 use strict;
  4         18  
  4         128  
9 4     4   18 use warnings;
  4         5  
  4         93  
10 4     4   18 use Carp qw(confess croak);
  4         7  
  4         176  
11 4     4   421 use Moo;
  4         9154  
  4         14  
12 4     4   2371 use namespace::clean;
  4         9217  
  4         32  
13              
14             our $VERSION = '0.08';
15              
16             # these defaults set from what the online version does at
17             # http://akana.conlang.org/tools/awkwords/
18             my %patterns = (
19             C => [qw/p t k s m n/],
20             N => [qw/m n/],
21             V => [qw/a i u/],
22             );
23              
24             has pattern => (
25             is => 'rw',
26             trigger => sub {
27             my ( $self, $pat ) = @_;
28             die "subpattern $pat does not exist" unless exists $patterns{$pat};
29             $self->_set_target( $patterns{$pat} );
30             },
31             );
32             has target => ( is => 'rwp', );
33              
34             ########################################################################
35             #
36             # METHODS
37              
38             sub get_patterns {
39 1     1 1 5 return %patterns;
40             }
41              
42             sub is_pattern {
43 14     14 1 32 my ( undef, $pat ) = @_;
44 14         50 return exists $patterns{$pat};
45             }
46              
47             sub render {
48 47     47 1 125 my ($self) = @_;
49              
50 47         51 my $ret;
51 47         64 my $target = $self->target;
52 47         62 my $type = ref $target;
53              
54             # this complication allows for subpatterns to point at other parse
55             # trees instead of just simple terminal strings (yes, you could
56             # create loops where a ->render points to itself (don't do that))
57             #
58             # NOTE walk sub must be kept in sync with this logic
59 47 100       71 if ( !$type ) {
60 5         9 $ret = $target;
61             } else {
62 42 100       67 if ( $type eq 'ARRAY' ) {
63             # do not need Math::Random::Discrete here as the weights are
64             # always equal; for weighted instead write that unit out
65             # manually via [a*2/e/i/o/u] or such
66 39   50     126 $ret = @{$target}[ rand @$target ] // '';
  39         78  
67             } else {
68 3         10 $ret = $target->render;
69             }
70             }
71 47         106 return $ret;
72             }
73              
74             sub set_patterns {
75 2     2 1 2612 my $class_or_self = shift;
76             # TODO error checking here may be beneficial if callers are in the
77             # habit of passing in data that blows up on ->render or ->walk
78 2         15 %patterns = ( %patterns, @_ );
79 2         10 return $class_or_self;
80             }
81              
82             sub update_pattern {
83 8     8 1 1475 my $class_or_self = shift;
84 8         14 my $pattern = shift;
85              
86             # TODO more error checking here may be beneficial if callers are in
87             # the habit of passing in data that blows up on ->render
88 8 100       35 croak "update needs a pattern and a list of values\n" unless @_;
89 7 100       24 croak "value must be defined" if !defined $_[0];
90              
91             # NOTE arrayref as single argument is saved without making a copy of
92             # the contents; this will allow the caller to potentially change
93             # that ref and thus influence what is stored in patterns after this
94             # update_pattern call
95 6 50       17 $patterns{$pattern} = @_ == 1 ? $_[0] : [@_];
96              
97 6         16 return $class_or_self;
98             }
99              
100             sub walk {
101 8     8 1 15 my ( $self, $callback ) = @_;
102              
103 8         18 $callback->($self);
104              
105 8         19 my $target = $self->target;
106 8         14 my $type = ref $target;
107              
108             # NOTE this logic must be kept in sync with render sub
109 8 100 100     22 if ( $type and $type ne 'ARRAY' ) {
110 2         6 $target->walk($callback);
111             }
112 8         15 return;
113             }
114              
115             1;
116             __END__