Skip to content

Commit 7fa9c1a

Browse files
mstuefermstuefer
committed
Add first version of ELIZA
1 parent bccdfd3 commit 7fa9c1a

File tree

8 files changed

+397
-0
lines changed

8 files changed

+397
-0
lines changed

‎lib/Assistant/Eliza/Assistant.pm

Lines changed: 118 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
package Assistant::Eliza::Assistant;
2+
3+
use Moose;
4+
5+
use Assistant::Eliza::State0;
6+
use Assistant::Eliza::State1;
7+
use Assistant::Eliza::State2;
8+
use Assistant::Eliza::State3;
9+
use Assistant::Eliza::State4;
10+
use Assistant::Eliza::State7;
11+
12+
has 'script' => (
13+
is => 'rw',
14+
isa => 'Str',
15+
);
16+
17+
has 'initial' => (
18+
is => 'rw',
19+
isa => 'ArrayRef[Str]',
20+
default => sub { [] },
21+
);
22+
23+
has 'fnl' => (
24+
is => 'rw',
25+
isa => 'ArrayRef[Str]',
26+
default => sub { [] },
27+
);
28+
29+
has 'quit' => (
30+
is => 'rw',
31+
isa => 'ArrayRef[Str]',
32+
default => sub { [] },
33+
);
34+
35+
has 'pre' => (
36+
is => 'rw',
37+
isa => 'HashRef',
38+
default => sub { {} },
39+
);
40+
41+
has 'post' => (
42+
is => 'rw',
43+
isa => 'HashRef',
44+
default => sub { {} },
45+
);
46+
47+
has 'synon' => (
48+
is => 'rw',
49+
isa => 'HashRef',
50+
default => sub { {} },
51+
);
52+
53+
has 'keywords' => (
54+
is => 'rw',
55+
isa => 'HashRef',
56+
default => sub { {} },
57+
);
58+
59+
has 'state' => (
60+
is => 'rw',
61+
isa => 'Object',
62+
);
63+
64+
has 'input_words' => (
65+
is => 'rw',
66+
isa => 'ArrayRef[Str]',
67+
);
68+
69+
has 'current_keywords' => (
70+
is => 'rw',
71+
isa => 'ArrayRef[Str]',
72+
default => sub { [] },
73+
);
74+
75+
has 'current_answer' => (
76+
is => 'rw',
77+
isa => 'Str',
78+
);
79+
80+
has 'current_wildcards' => (
81+
is => 'rw',
82+
isa => 'ArrayRef[Str]',
83+
default => sub { [] },
84+
);
85+
86+
has 'last_decomp' => (
87+
is => 'rw',
88+
isa => 'Str',
89+
);
90+
91+
# methods
92+
93+
# read/parse the script
94+
sub init {
95+
my ($self) = @_;
96+
97+
$self->state(Assistant::Eliza::State0->new());
98+
$self->state->process($self);
99+
}
100+
101+
# process a given input, returning corresponding output
102+
sub process {
103+
my ($self) = @_;
104+
105+
my $start_state = Assistant::Eliza::State1->new();
106+
my $final_state = Assistant::Eliza::State7->new();
107+
108+
while (<>) {
109+
do {
110+
$self->state->process($self, $_);
111+
} until( $self->state->isa(ref $final_state) );
112+
$self->state($start_state);
113+
}
114+
}
115+
116+
no Moose;
117+
__PACKAGE__->meta->make_immutable;
118+
1;

‎lib/Assistant/Eliza/State0.pm

Lines changed: 126 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,126 @@
1+
package Assistant::Eliza::State0;
2+
3+
use Switch;
4+
use Moose;
5+
6+
with 'Assistant::Eliza::Staterole';
7+
8+
has 'current_key' => (
9+
is => 'rw',
10+
isa => 'Str',
11+
);
12+
13+
has 'current_key_decomp' => (
14+
is => 'rw',
15+
isa => 'Str',
16+
);
17+
18+
sub process {
19+
my ($self, $ass) = @_;
20+
21+
open(my $fh, '<:encoding(UTF-8)', $ass->script)
22+
or die "$ass->script not found";
23+
24+
while(my $row = <$fh>) {
25+
$row =~ s/^\s+//; # remove leading whitespaces
26+
my ($k, $v) = split /\s*:\s*/, $row, 2;
27+
$self->_clean(\$k, \$v);
28+
switch($k) {
29+
case "initial" { $self->_add_arr_value($ass, $k, $v) }
30+
case "fnl" { $self->_add_arr_value($ass, $k, $v) }
31+
case "quit" { $self->_add_arr_value($ass, $k, $v) }
32+
case "pre" { $self->_add_key($ass, $k, $v) }
33+
case "post" { $self->_add_key($ass, $k, $v) }
34+
case "synon" { $self->_add_synon($ass, $k, $v) }
35+
case "key" { $self->_add_key($ass, $k, $v) }
36+
case "decomp" { $self->_add_key_decomp($ass, 'keywords', $v) }
37+
case "reasmb" { $self->_add_key_reasmb($ass, 'keywords', $v) }
38+
else { $self->_not_found($ass, $v) }
39+
}
40+
}
41+
42+
#print "Welcome, how can I help you?\n\n";
43+
$self->_welcome($ass);
44+
45+
#print STDERR Data::Dumper::Dumper $ass;
46+
$ass->state(Assistant::Eliza::State1->new());
47+
}
48+
49+
sub _clean {
50+
${$_[1]} = 'fnl' if( ${$_[1]} eq 'final' ); # overwrite final with fnl as key
51+
chomp(${$_[2]}); # remove \n on value
52+
}
53+
54+
sub _add_arr_value {
55+
my ($self, $ass, $key, $val) = @_;
56+
push(@{ $ass->$key }, $val);
57+
}
58+
59+
sub _add_key {
60+
my ($self, $ass, $key, $val) = @_;
61+
switch($key) {
62+
case "pre" { $self->_add_key_pre($ass, $key, $val) }
63+
case "post" { $self->_add_key_post($ass, $key, $val) }
64+
case "key" { $self->_add_key_key($ass, 'keywords', $val) }
65+
}
66+
}
67+
68+
sub _add_key_pre {
69+
my ($self, $ass, $key, $val) = @_;
70+
my ($w1, $w2) = split(/\s* \s*/, $val, 2);
71+
${ $ass->$key }{$w1} = $w2;
72+
}
73+
74+
sub _add_key_post {
75+
$_[0]->_add_key_pre($_[1], $_[2], $_[3]);
76+
}
77+
78+
sub _add_key_key {
79+
my ($self, $ass, $key, $val) = @_;
80+
my ($word, $weight) = split(/\s* (\d+)/, $val, 2);
81+
$self->current_key($word);
82+
$weight = 0 unless(defined($weight));
83+
${ $ass->$key }{ $word } = { weight => $weight, decomp => {} };
84+
}
85+
86+
sub _add_key_decomp {
87+
my ($self, $ass, $key, $val) = @_;
88+
$val =~ s/\*/(.*)/g; # substitude * with .*
89+
${ $ass->$key }{ $self->current_key }{ decomp }{ $val } = [];
90+
$self->current_key_decomp($val);
91+
}
92+
93+
sub _add_key_reasmb {
94+
my ($self, $ass, $key, $val) = @_;
95+
push(
96+
@{${$ass->$key}{$self->current_key}{decomp}{$self->current_key_decomp}},
97+
$val
98+
);
99+
# TODO create possibility to count how often we have chosen the reasmb,
100+
# s.t. we use them all once before repeating
101+
#push(
102+
# @{${$ass->$key}{$self->current_key}{decomp}{$self->current_key_decomp}},
103+
# { $val => 0 }
104+
#);
105+
}
106+
107+
sub _add_synon {
108+
my ($self, $ass, $key, $val) = @_;
109+
foreach my $w (split ' ', $val) {
110+
@{ ${ $ass->$key }{$w} } = grep { $_ ne $w } (split ' ', $val);
111+
}
112+
}
113+
114+
sub _not_found {
115+
my ($self, $ass, $row) = @_;
116+
print STDERR "Could not elaborate $row\n";
117+
}
118+
119+
sub _welcome {
120+
print @{ $_[1]->initial }[ rand @{ $_[1]->initial } ];
121+
print "\n\n";
122+
}
123+
124+
no Moose;
125+
__PACKAGE__->meta->make_immutable;
126+
1;

‎lib/Assistant/Eliza/State1.pm

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
package Assistant::Eliza::State1;
2+
3+
use Moose;
4+
5+
with 'Assistant::Eliza::Staterole';
6+
7+
# split user input line in words and execute pre-substitutions
8+
sub process {
9+
my ($self, $ass, $input) = @_;
10+
11+
chomp($input);
12+
$ass->input_words( [ split / /, $input ] );
13+
14+
map {
15+
$_=lc;
16+
s/[?!.,]//; # remove useless chars
17+
$ass->{pre}{$_} if defined $ass->{pre}{$_};
18+
} @{ $ass->input_words };
19+
20+
$ass->state(Assistant::Eliza::State2->new());
21+
}
22+
23+
no Moose;
24+
__PACKAGE__->meta->make_immutable;
25+
1;

‎lib/Assistant/Eliza/State2.pm

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
package Assistant::Eliza::State2;
2+
3+
use Moose;
4+
5+
with 'Assistant::Eliza::Staterole';
6+
7+
# make a list of all keywords in input sorted in descendent way
8+
sub process {
9+
my ($self, $ass, $input) = @_;
10+
11+
$self->_exit($ass) if @{ $ass->input_words }[0] eq 'quit';
12+
13+
undef @{ $ass->current_keywords };
14+
15+
foreach my $w (@{ $ass->input_words }) {
16+
push(@{ $ass->current_keywords }, $w) if(defined(${$ass->keywords}{$w}));
17+
}
18+
19+
@{ $ass->current_keywords } = sort
20+
{ $ass->{keywords}{$b}->{weight} <=> $ass->{keywords}{$a}{weight} }
21+
@{ $ass->current_keywords};
22+
23+
$ass->state(Assistant::Eliza::State3->new());
24+
}
25+
26+
sub _exit {
27+
print @{ $_[1]->fnl }[ rand @{ $_[1]->fnl} ];
28+
print "\n";
29+
print @{ $_[1]->quit }[ rand @{ $_[1]->quit } ];
30+
print "\n\n";
31+
exit(0);
32+
}
33+
34+
no Moose;
35+
__PACKAGE__->meta->make_immutable;
36+
1;

‎lib/Assistant/Eliza/State3.pm

Lines changed: 55 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,55 @@
1+
package Assistant::Eliza::State3;
2+
3+
use Moose;
4+
5+
with 'Assistant::Eliza::Staterole';
6+
7+
# TODO split in additional states
8+
9+
# -- For a given keyword a list of decomposition patterns is searched
10+
# first one that matches is selected
11+
# -- For matching decomposition pattern a reassembly pattern is selected
12+
# -- A set of post-substitutions takes place TODO
13+
sub process {
14+
my ($self, $ass, $input) = @_;
15+
16+
foreach my $keyword (@{ $ass->current_keywords }) {
17+
$self->_process_keyword($ass, $input, $keyword)
18+
unless($ass->current_answer);
19+
}
20+
21+
$ass->state(Assistant::Eliza::State4->new());
22+
}
23+
24+
# TODO save which decomp was already used, use them all before reusing one
25+
sub _process_keyword {
26+
my ($self, $ass, $input, $w) = @_;
27+
$w = lc($w);
28+
29+
LINE: foreach my $decomp ( keys %{ $ass->{keywords}{$w}{decomp} } ) {
30+
next LINE unless (join(" ", @{ $ass->input_words }) =~ /$decomp/);
31+
32+
#$ass->last_decomp($decomp);
33+
34+
# define all wildcards to possibly substitude later
35+
@{ $ass->current_wildcards } = join(" ", @{ $ass->input_words }) =~ /$decomp/;
36+
37+
# define a random answer
38+
my @arr = @{ $ass->{keywords}{$w}{decomp}{$decomp} };
39+
$ass->current_answer($arr[rand @arr]);
40+
41+
# next if chosen answer does not contain anything to substitude
42+
next LINE unless($ass->current_answer =~ m/(\d+)/);
43+
44+
# substitude placeholders
45+
my $sub = defined @{ $ass->current_wildcards }[($1 -1)] ? @{ $ass->current_wildcards }[($1 - 1)] : "mmmmm";
46+
my $res = $ass->current_answer;
47+
$res =~ s/\(\d+\)/$sub/;
48+
$ass->current_answer($res);
49+
}
50+
51+
}
52+
53+
no Moose;
54+
__PACKAGE__->meta->make_immutable;
55+
1;

‎lib/Assistant/Eliza/State4.pm

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
package Assistant::Eliza::State4;
2+
3+
use Moose;
4+
5+
with 'Assistant::Eliza::Staterole';
6+
7+
# print answer
8+
sub process {
9+
my ($self, $ass, $input) = @_;
10+
11+
print "\n\t".($ass->current_answer ? $ass->current_answer : "Please elaborate on this")."\n\n";
12+
$ass->current_answer('');
13+
14+
$ass->state(Assistant::Eliza::State7->new());
15+
}
16+
17+
no Moose;
18+
__PACKAGE__->meta->make_immutable;
19+
1;

‎lib/Assistant/Eliza/State7.pm

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
package Assistant::Eliza::State7;
2+
3+
use Moose;
4+
5+
with 'Assistant::Eliza::Staterole';
6+
7+
sub process {
8+
# TODO
9+
}
10+
11+
1;

0 commit comments

Comments
 (0)