File Coverage

blib/lib/String/Markov.pm
Criterion Covered Total %
statement 96 96 100.0
branch 24 24 100.0
condition 11 12 91.6
subroutine 13 13 100.0
pod 4 8 50.0
total 148 153 96.7


line stmt bran cond sub pod time code
1             package String::Markov;
2              
3             # ABSTRACT: A Moo-based, text-oriented Markov Chain module
4              
5             our $VERSION = 0.009;
6              
7 1     1   763 use 5.010;
  1         2  
  1         33  
8 1     1   503 use Moo;
  1         11258  
  1         4  
9 1     1   1593 use namespace::autoclean;
  1         11776  
  1         6  
10              
11 1     1   598 use Unicode::Normalize qw(normalize);
  1         1834  
  1         83  
12 1     1   7 use List::Util qw(sum);
  1         1  
  1         1367  
13              
14             has normalize => (is => 'rw', default => sub { 'C' });
15             has do_chomp => (is => 'rw', default => sub { 1 });
16             has null => (is => 'ro', default => sub { "\0" });
17             has stable => (is => 'ro', default => sub { 1 });
18             has order => (is => 'ro', isa => sub {
19             die "Need an integer greater than zero" if !$_[0] || $_[0] =~ /\D/;
20             }, default => sub { 2 });
21              
22             has ['split_sep','join_sep'] => (
23             is => 'rw',
24             default => sub { undef }
25             );
26              
27             has ['transition_count','row_sum'] => (
28             is => 'ro',
29             isa => sub { die "Need a hash ref" if ref $_[0] ne 'HASH'; },
30             default => sub { {} }
31             );
32              
33             around BUILDARGS => sub {
34             my ($orig, $class, @arg) = @_;
35             my %ahash;
36              
37             %ahash = @arg == 1 ? %{$arg[0]} : @arg;
38              
39             my $sep = delete $ahash{sep} // '';
40             die "ERR: sep argument must be scalar; did you mean to set split_sep instead?" if ref $sep;
41             $ahash{split_sep} //= $sep;
42             $ahash{join_sep} //= $sep;
43              
44             return $class->$orig(\%ahash);
45             };
46              
47             sub join_prob {
48 146     146 0 133 my ($self, $orig_prob) = @_;
49 146         95 my %p;
50              
51 146         89 @p{@{$orig_prob->[0]}} = @{$orig_prob->[1]};
  146         246  
  146         147  
52              
53 146         277 return \%p;
54             }
55              
56             sub split_prob {
57 488     488 0 375 my ($self, $orig_prob) = @_;
58              
59 488 100       632 if ($self->stable) {
60 356         764 my @k = sort keys %$orig_prob;
61             return [
62 356         1082 \@k,
63 356         362 [@{$orig_prob}{@k}],
64             ];
65             } else {
66             return [
67 132         522 [keys %$orig_prob],
68             [values %$orig_prob],
69             ];
70             }
71             }
72              
73             sub split_all_prob {
74 7     7 0 8 my $self = shift;
75 7         9 my $tc = $self->transition_count;
76 7         10 my $nt = {};
77              
78 7         31 while (my ($state, $prob) = each %$tc) {
79 316         362 $nt->{$state} = $self->split_prob($prob);
80             }
81              
82 7         265 %$tc = %$nt;
83             }
84              
85             sub split_line {
86 42     42 1 41 my ($self, $sample) = @_;
87 42 100       102 if (my $norm = $self->normalize) {
88 40         106 $sample = normalize($norm, $sample);
89             }
90 42         794 return split($self->split_sep, $sample);
91             }
92              
93             sub add_sample {
94 46     46 1 10564 my ($self, $sample) = @_;
95 46         82 my $n = $self->order;
96 46         65 my $null = $self->null;
97              
98 46         50 my $sref = ref $sample;
99 46         82 my @nms = ($null,) x $n;
100              
101 46 100       122 if ($sref eq 'ARRAY') {
    100          
102 2         3 push @nms, @$sample;
103             } elsif (!$sref) {
104 43 100       108 die 'ERR: missing split separator,' if !defined $self->split_sep;
105 42         68 push @nms, $self->split_line($sample);
106             } else {
107 1         9 die "ERR: bad sample type $sref";
108             }
109              
110 44         69 push @nms, $null;
111              
112 44   100     103 my $sep = $self->join_sep // '';
113 44         61 my $count = $self->transition_count;
114 44         54 my $sum = $self->row_sum;
115 44         95 for my $i (0 .. ($#nms - $n)) {
116 611         782 my $cur = join($sep, @nms[$i .. ($i + $n - 1)]);
117 611         522 my $nxt = $nms[$i + $n];
118 611         542 my $prob = $count->{$cur};
119 611 100 100     1288 if ($prob && ref $prob ne 'HASH') {
120 146         198 $count->{$cur} = $self->join_prob($prob);
121             }
122 611         906 ++$count->{$cur}{$nxt};
123 611         749 ++$sum->{$cur};
124             }
125              
126 44         237 return $self;
127             }
128              
129             sub add_files {
130 7     7 1 993 my ($self, @files) = @_;
131 7         17 my $do_chomp = $self->do_chomp;
132              
133 7         15 local @ARGV = @files;
134 7         304 while(my $sample = <>) {
135 26 100       57 chomp $sample if $do_chomp;
136 26         37 $self->add_sample($sample);
137             }
138              
139 7         19 $self->split_all_prob();
140              
141 7         62 return $self;
142             }
143              
144             sub sample_next_state {
145 6593     6593 0 8222 my ($self, @cur_state) = @_;
146 6593 100       10370 die "ERR: wrong amount of state" if @cur_state != $self->order;
147              
148 6590         6711 my $count = $self->transition_count;
149 6590         5827 my $sum = $self->row_sum;
150              
151 6590   100     11785 my $cur = join($self->join_sep // '', @cur_state);
152 6590         7031 my $thresh = $sum->{$cur};
153 6590 100       8115 return undef if !$thresh;
154              
155 6574         5783 $thresh *= rand();
156              
157 6574         6076 my $prob = $count->{$cur};
158 6574 100       9013 if (ref $prob ne 'ARRAY') {
159 172         198 $prob = $self->split_prob($prob);
160 172         216 $count->{$cur} = $prob;
161             }
162              
163 6574         4570 my $s = 0;
164 6574         4367 my $i = 0;
165 6574         4478 my ($k, $v) = @{$prob};
  6574         6409  
166 6574   66     4937 do {
167 7334         15464 $s += $v->[$i];
168             } while ($thresh > $s && ++$i);
169 6574         17251 return $k->[$i];
170             }
171              
172             sub generate_sample {
173 421     421 1 48818 my ($self) = @_;
174              
175 421         493 my $null = $self->null;
176 421         442 my $n = $self->order;
177 421   100     693 my $sep = $self->join_sep // '';
178 421         566 my @nm = ($null,) x $n;
179              
180 421         342 do {
181 6546         9716 push @nm, $self->sample_next_state(@nm[-$n .. -1]);
182             } while ($nm[-1] ne $null);
183              
184 421         2308 @nm = @nm[$n .. ($#nm-1)];
185              
186             return wantarray ?
187 421 100       2201 @nm :
    100          
188             defined $self->join_sep ?
189             join($sep, @nm) :
190             \@nm;
191              
192             }
193              
194             __PACKAGE__->meta->make_immutable;
195              
196             1;
197              
198             __END__