File Coverage

blib/lib/Eliza/Chatbot/Brain.pm
Criterion Covered Total %
statement 87 100 87.0
branch 17 24 70.8
condition 5 8 62.5
subroutine 8 8 100.0
pod 3 3 100.0
total 120 143 83.9


line stmt bran cond sub pod time code
1             package Eliza::Chatbot::Brain;
2              
3 9     9   68 use Moo;
  9         22  
  9         61  
4 9     9   3038 use MooX::LazierAttributes;
  9         21  
  9         62  
5              
6 9     9   7191 use Ref::Util qw(is_scalarref is_blessed_arrayref);
  9         15448  
  9         14727  
7              
8             attributes(
9             decomp_matches => [rw, [ ], {lzy}],
10             [qw/options last/] => [rw, nan, {lzy}],
11             );
12              
13             sub preprocess {
14 13     13 1 8046 my ($self, $string) = @_;
15 13         42 my @orig_words = split / /, $string;
16              
17 13         26 my @converted_words;
18 13         39 foreach my $word ( @orig_words ) {
19 32         93 $word =~ s{[?!,]|but}{.}g;
20 32         67 push @converted_words, $word;
21             }
22              
23 13         48 my $formated = join ' ', @converted_words;
24 13         37 @converted_words = split /\./, $formated;
25 13         52 return @converted_words;
26             }
27              
28             sub postprocess {
29 19     19 1 8065 my ($self, $string) = @_;
30 19 50       83 if ( is_blessed_arrayref($string) ) {
    100          
31 0         0 for (my $i = 1; $i < scalar @{$string}; $i++){
  0         0  
32 0         0 $string->[$i] =~ s/([,;?!]|\.*)$//;
33             }
34             } elsif ( is_scalarref(\$string) ) {
35 13         76 $string =~ tr/ / /s; # Eliminate any duplicate space characters.
36 13         40 $string =~ s/[ ][?]$/?/; # Eliminate any spaces before the question mark.
37             }
38 19         59 return $string;
39             }
40              
41             sub _test_quit {
42 19     19   10411 my ($self, $string) = @_;
43 19         35 foreach my $quitword (@{$self->options->data->quit}) {
  19         355  
44 29 100       459 return 1 if $string =~ m{$quitword}xms;
45             }
46             }
47              
48             sub _debug_memory {
49 6     6   4985 my $self = shift;
50 6         11 my @memory = @{$self->options->memory};
  6         101  
51 6         62 my $string = sprintf("%s item(s) in memory stack:\n", scalar @memory);
52 6         13 foreach my $msg (@memory) {
53 21         50 $string .= sprintf("\t\t->%s\n", $msg);
54             }
55 6         28 return $string;
56             }
57              
58             sub transform {
59 13     13 1 8596 my ($self, $string, $use_memory) = @_;
60              
61 13         26 my ($this_decomp, $reasmbkey);
62 13         39 my $options = $self->options;
63 13 50       38 $options->debug_text(sprintf("\t[Pulling string \"%s\" from memory.]\n", $string))
64             if $use_memory;
65              
66 13 100       34 if ($self->_test_quit($string)){
67 5         19 $self->last(1);
68 5         117 return $options->data->final->[ $options->myrand(scalar @{$options->data->final}) ];
  5         196  
69             }
70              
71             # Default to a really low rank.
72 8         159 my $rank = -2;
73 8         15 my $reasmb = "";
74 8         15 my $goto = "";
75              
76             # First run the string through preprocess.
77 8         23 my @string_parts = $self->preprocess( $string );
78              
79 8         162 $self->decomp_matches([]);
80             # Examine each part of the input string in turn.
81 8         61 foreach my $string_part (@string_parts) {
82              
83             # Run through the whole list of keywords.
84 8         13 KEYWORD: foreach my $keyword (keys %{$options->data->decomp}) {
  8         125  
85              
86             # Check to see if the input string contains a keyword
87             # which outranks any we have found previously
88             # (On first loop, rank is set to -2.)
89 24 100 66     595 if ( ($string_part =~ /\b$keyword\b/i or $keyword eq $goto)
      66        
90             and
91             $rank < $options->data->key->{$keyword}
92             )
93             {
94             # If we find one, then set $rank to equal
95             # the rank of that keyword.
96 6         253 $rank = $options->data->key->{$keyword};
97 6   50     226 $options->debug_text(
98             sprintf("%s \trank:%d keyword:%s",
99             ($options->debug_text // ''), $rank, $keyword)
100             );
101              
102             # Now let's check all the decomposition rules for that keyword.
103 6         237 foreach my $decomp (@{$options->data->decomp->{$keyword}}) {
  6         102  
104              
105             # Change '*' to '\b(.*)\b' in this decomposition rule,
106             # so we can use it for regular expressions. Later,
107             # we will want to isolate individual matches to each wildcard.
108 6         176 ($this_decomp = $decomp) =~ s/\s*\*\s*/\\b\(\.\*\)\\b/g;
109             # If this docomposition rule contains a word which begins with '@',
110             # then the script also contained some synonyms for that word.
111             # Find them all using %synon and generate a regular expression
112             # containing all of them.
113 6 50       20 if ($this_decomp =~ /\@/ ) {
114 0         0 $this_decomp =~ s/.*\@(\w*).*/$1/i;
115 0         0 my $synonyms = join ('|', @{$options->data->synon->{$this_decomp}} );
  0         0  
116 0         0 $this_decomp =~ s/(.*)\@$this_decomp(.*)/$1($this_decomp\|$synonyms)$2/g;
117             }
118              
119             $options->debug_text(
120 6         163 sprintf("%s\n\t\t: %s", $options->debug_text, $decomp)
121             );
122            
123             # Using the regular expression we just generated,
124             # match against the input string. Use empty "()"'s to
125             # eliminate warnings about uninitialized variables.
126 6 50       204 if ($string_part =~ /$this_decomp()()()()()()()()()()()/i) {
127              
128             # If this decomp rule matched the string,
129             # then create an array, so that we can refer to matches
130             # to individual wildcards. Use '0' as a placeholder
131             # (we don't want to refer to any "zeroth" wildcard).
132 6         67 my @decomp_matches = ("0", $1, $2, $3, $4, $5, $6, $7, $8, $9, $10);
133            
134              
135 6         11 push @{$self->decomp_matches}, { matches => \@decomp_matches };
  6         112  
136            
137 6         143 $options->debug_text(
138             sprintf( "%s : %s \n",
139             $options->debug_text, join( ' ', @decomp_matches))
140             );
141            
142             # Using the keyword and the decomposition rule,
143             # reconstruct a key for the list of reassamble rules.
144 6         81 $reasmbkey = join $;, $keyword, $decomp;
145             # Get the list of possible reassembly rules for this key.
146 6         11 my @these_reasmbs = @{$options->data->reasmb->{$reasmbkey}};
  6         106  
147              
148             # Pick out a reassembly rule at random :).
149 6         174 $reasmb = $these_reasmbs[ $options->myrand( scalar @these_reasmbs ) ];
150 6         113 $options->debug_text(
151             sprintf("%s \t\t--> %s\n",
152             $options->debug_text, $reasmb )
153             );
154              
155             # If the reassembly rule we picked contains the word "goto",
156             # then we start over with a new keyword. Set $keyword to equal
157             # that word, and start the whole loop over.
158 6 50       77 if ($reasmb =~ m/^goto\s(\w*).*/i) {
159 0         0 $options->debug_text(sprintf("%s \$1 = $1\n",
160             $options->debug_text));
161 0         0 $goto = $keyword = $1;
162 0         0 $rank = -2;
163 0         0 redo KEYWORD;
164             }
165              
166             # Otherwise, using the matches to wildcards which we stored above,
167             # insert words from the input string back into the reassembly rule.
168             # [THANKS to Gidon Wise for submitting a bugfix here]
169 6         97 my $decomp_matches = $self->decomp_matches;
170 6         37 foreach my $match (@{$decomp_matches}) {
  6         25  
171 6         19 $match->{matches} = $self->postprocess( $match->{matches} );
172 6         35 for (my $i = 1; $i < 10; $i++) {
173 54         433 $reasmb =~ s/\($i\)/$match->{matches}->[$i]/g;
174             }
175             }
176              
177             # Move on to the next keyword. If no other keywords match,
178             # then we'll end up actually using the $reasmb string
179             # we just generated above.
180 6         26 next KEYWORD;
181              
182             } # End if ($string_part =~ /$this_decomp/i)
183              
184 0         0 $options->debug_text($options->debug_text . "\n");
185             } # End DECOMP: foreach $decomp (@{ $self->{decomplist}->{$keyword} })
186              
187             } # End if ( ($string_part =~ /\b$keyword\b/i or $keyword eq $goto)
188              
189             } # End KEYWORD: foreach $keyword (keys %{ $self->{decomplist})
190            
191             } # End STRING_PARTS: foreach $string_part (@string_parts) {
192              
193 8 100       41 $reasmb = $self->transform("xnone", "") if $reasmb eq "";
194            
195 8         19 $reasmb = $self->postprocess($reasmb);
196            
197 8 50       163 if ($options->memory_on) {
198             # Shift out the least-recent item from the bottom
199             # of the memory stack if the stack exceeds the max size.
200 8 50       137 shift @{$options->memory} if scalar @{$options->memory} >= $options->max_memory_size;
  0         0  
  8         135  
201             # push in the current reasem string
202 8         266 push @{$options->memory}, $reasmb;
  8         121  
203              
204             $options->debug_text(sprintf("%s \t%d item(s) in memory.\n",
205 8         164 $options->debug_text, scalar @{$options->memory} ));
  8         147  
206             }
207              
208             # Save the return string so that forgetful calling programs
209             # can ask the bot what the last reply was.
210 8         329 $options->transform_text($reasmb);
211 8         74 return $reasmb;
212             }
213              
214             1;
215              
216             __END__