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__ |