1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
use v5.10;
use warnings;
# WHO IS NEXT TO WHOM?
use Parse::RecDescent;
$grammar =
q{
<nocheck>
inputs : input(s)
input : who_question "\n" {1}
| is_question "\n" {1}
| statement "\n" {1}
| /bye|quit|exit/ { exit }
| <reject:!$text> <error> # ERROR IF NOT END OF TEXT
| { print STDERR "resyncing\n" }
{ _error(@$_) foreach @{$thisparser->{errors}}; }
<resync>
statement: namelist are <commit> 'next' 'to' namelist
{ ::nextto $item[1], $item[6], $thisline; 1 }
| <error?> <reject>
who_question:
'who' <commit> are 'next' 'to' name '?'
{ ::whonextto $item[6] ; 1 }
| <error?> <reject>
is_question:
'is' <commit> name 'next' 'to' name '?'
{ ::isnextto($item[3], $item[6]); 1 }
| <error?> <reject>
namelist : name(s) 'and' <commit> namelist
{ [ @{$item[1]}, @{$item[3]} ] }
| name(s)
name : ...!'who' ...!'and' ...!are /[A-Za-z]+/
are : 'is' | 'are'
};
$parse = new Parse::RecDescent ($grammar);
$parse->{tokensep} = '[ \t]*';
$input = '';
print "> ";
while (<>)
{
if (/^\.$/) { $parse->inputs($input) || print "huh?\n"; $input = '' }
else { $input .= $_ }
print "> ";
}
sub nextto($$$)
{
foreach $A ( @{$_[0]} ) {
foreach $B ( @{$_[1]} ) {
nexttoAB($A,$B,$_[2]);
}
}
print "okay\n";
}
sub nexttoAB($$$)
{
$nextto{$_[0]} or $nextto{$_[0]} = [];
$nextto{$_[1]} or $nextto{$_[1]} = [];
push @{$nextto{$_[0]}}, $_[1];
push @{$nextto{$_[1]}}, $_[0];
print "Learnt something from line $_[2]\n";
}
sub whonextto($)
{
if (defined $nextto{$_[0]})
{ print join(" and ", @{$nextto{$_[0]}}) . ".\n"; }
else
{ print "sorry, I've never heard of $_[0].\n"; }
}
sub isnextto($$)
{
if (!$nextto{$_[0]})
{ print "sorry, I've never heard of $_[0].\n"; }
elsif (!$nextto{$_[1]})
{ print "sorry, I've never heard of $_[1].\n"; }
else
{
foreach $name (@{$nextto{$_[0]}})
{
if ($name eq $_[1]) { print "yes\n"; return }
}
print "no\n";
}
}
|
