File Coverage

lib/AI/Prolog/Parser.pm
Criterion Covered Total %
statement 243 294 82.6
branch 48 64 75.0
condition 10 17 58.8
subroutine 33 44 75.0
pod 0 17 0.0
total 334 436 76.6


line stmt bran cond sub pod time code
1             package AI::Prolog::Parser;
2             $REVISION = '$Id: Parser.pm,v 1.9 2005/08/06 23:28:40 ovid Exp $';
3              
4             $VERSION = '0.10';
5 13     13   12224 use strict;
  13         27  
  13         469  
6 13     13   69 use warnings;
  13         24  
  13         448  
7 13     13   70 use Carp qw( confess croak );
  13         30  
  13         893  
8 13     13   17977 use Regexp::Common;
  13         77175  
  13         73  
9 13     13   925349 use Hash::Util 'lock_keys';
  13         2334  
  13         148  
10              
11             # debugging stuff
12 13     13   9514 use Clone;
  13         38212  
  13         678  
13 13     13   483299 use Text::Balanced qw/extract_quotelike extract_delimited/;
  13         589270  
  13         1558  
14              
15 13     13   154 use aliased 'AI::Prolog::Engine';
  13         28  
  13         274  
16 13     13   1377 use aliased 'AI::Prolog::KnowledgeBase';
  13         23  
  13         66  
17 13     13   1671 use aliased 'AI::Prolog::Parser::PreProcessor';
  13         26  
  13         52  
18 13     13   1252 use aliased 'AI::Prolog::Term';
  13         32  
  13         92  
19 13     13   1817 use aliased 'AI::Prolog::Term::Number';
  13         137  
  13         60  
20 13     13   1591 use aliased 'AI::Prolog::TermList';
  13         59  
  13         58  
21 13     13   1542 use aliased 'AI::Prolog::TermList::Clause';
  13         32  
  13         52  
22 13     13   1538 use aliased 'AI::Prolog::TermList::Primitive';
  13         32  
  13         58  
23              
24             my $ATOM = qr/[[:alpha:]][[:alnum:]_]*/;
25              
26 13     13   2511 use constant NULL => 'null';
  13         33  
  13         38222  
27              
28             sub new {
29 76     76 0 2961 my ( $class, $string ) = @_;
30 76         439 my $self = bless {
31             _str => PreProcessor->process($string),
32             _posn => 0,
33             _start => 0,
34             _varnum => 0,
35             _internal => 0,
36             _vardict => {},
37             } => $class;
38 76         346 lock_keys %$self;
39 76         856 return $self;
40             }
41              
42             sub _vardict_to_string {
43 0     0   0 my $self = shift;
44 0         0 return "{"
45             . (
46 0         0 join ', ' => map { join '=' => $_->[0], $_->[1] }
47 0         0 sort { $a->[2] <=> $b->[2] }
48 0         0 map { [ $_, $self->_sortable_term( $self->{_vardict}{$_} ) ] }
49 0         0 keys %{ $self->{_vardict} }
50             ) . "}";
51             }
52              
53             sub _sortable_term {
54 0     0   0 my ( $self, $term ) = @_;
55 0         0 my $string = $term->to_string;
56 0         0 my $number = substr $string => 1;
57 0         0 return $string, $number;
58             }
59              
60             sub to_string {
61 0     0 0 0 my $self = shift;
62 0         0 my $output = Clone::clone($self);
63 0         0 $output->{_vardict} = $self->_vardict_to_string;
64 0         0 return "{"
65             . substr( $self->{_str}, 0, $self->{_posn} ) . " ^ "
66             . substr( $self->{_str}, $self->{_posn} ) . " | "
67             . $self->_vardict_to_string . " }";
68             }
69              
70 0     0   0 sub _posn { shift->{_posn} }
71 0     0   0 sub _str { shift->{_str} }
72 0     0   0 sub _start { shift->{_start} }
73 0     0   0 sub _varnum { shift->{_varnum} }
74 0     0   0 sub _vardict { shift->{_vardict} }
75              
76             sub _internal {
77 0     0   0 my $self = shift;
78 0 0       0 if (@_) {
79 0         0 $self->{_internal} = shift;
80 0         0 return $self;
81             }
82 0         0 return $self->{_internal};
83             }
84              
85             # get the current character
86             sub current {
87 49367     49367 0 53434 my $self = shift;
88 49367 100       80408 return '#' if $self->empty;
89 49267         208997 return substr $self->{_str} => $self->{_posn}, 1;
90             }
91              
92             # peek at the next character
93             sub peek {
94 5     5 0 8 my $self = shift;
95 5 50       11 return '#' if $self->empty;
96 5   50     36 return substr( $self->{_str} => ( $self->{_posn} + 1 ), 1 ) || '#';
97             }
98              
99             # is the parsestring empty?
100             sub empty {
101 49788     49788 0 49474 my $self = shift;
102 49788         157954 return $self->{_posn} >= length $self->{_str};
103             }
104              
105             my $LINENUM = 1;
106              
107             sub linenum {
108 22     22 0 39 my $self = shift;
109 22 50       152 if (@_) {
110 22         37 $LINENUM = shift;
111 22         46 return $self;
112             }
113 0         0 $LINENUM;
114             }
115              
116             sub advance_linenum {
117 479     479 0 578 my $self = shift;
118 479         1198 $LINENUM++;
119             }
120              
121             # Move a character forward
122             sub advance {
123 13178     13178 0 14747 my $self = shift;
124              
125             # print $self->current; # XXX
126 13178 50       31714 $self->{_posn}++ unless $self->{_posn} >= length $self->{_str};
127 13178 100       21788 $self->advance_linenum if $self->current =~ /[\r\n]/;
128             }
129              
130             # all three get methods must be called before advance
131             # recognize a name (sequence of alphanumerics)
132             # XXX the java methods do not directly translate, so
133             # we need to revisit this if it breaks
134             # XXX Update: There was a subtle bug. I think
135             # I've nailed it, though. The string index was off by one
136             sub getname {
137 1366     1366 0 2373 my $self = shift;
138              
139 1366         1925 $self->{_start} = $self->{_posn};
140 1366         1571 my $getname;
141 1366 100       2487 if ( $self->current =~ /['"]/ ) {
142              
143             # Normally, Prolog distinguishes between single and double quoted strings
144 3         6 my $string = substr $self->{_str} => $self->{_start};
145 3         16 $getname = extract_delimited($string);
146 3         273 $self->{_posn} += length $getname;
147 3         10 return substr $getname => 1, length($getname) - 2; # strip the quotes
148             }
149             else {
150 1363         4569 my $string = substr $self->{_str} => $self->{_start};
151 1363         8910 ($getname) = $string =~ /^($ATOM)/;
152 1363         3061 $self->{_posn} += length $getname;
153 1363         4155 return $getname;
154             }
155             }
156              
157             # recognize a number
158             # XXX same issues as getname
159             sub getnum {
160 309     309 0 371 my $self = shift;
161              
162 309         469 $self->{_start} = $self->{_posn};
163 309         996 my $string = substr $self->{_str} => $self->{_start};
164 309         1932 my ($getnum) = $string =~ /^($RE{num}{real})/;
165 309 100       79908 if ( '.' eq substr $getnum => -1, 1 ) {
166 234         793 $getnum = substr $getnum => 0, length($getnum) - 1;
167             }
168 309         529 $self->{_posn} += length $getnum;
169 309         1057 return $getnum;
170             }
171              
172             # get the term corresponding to a name.
173             # if the name is new, create a new variable
174             sub getvar {
175 674     674 0 1030 my $self = shift;
176 674         1091 my $string = $self->getname;
177 674         1386 my $term = $self->{_vardict}{$string};
178 674 100       1339 unless ($term) {
179 492         1711 $term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum?
180 492         1380 $self->{_vardict}{$string} = $term;
181             }
182 674         1616 return ( $term, $string );
183             }
184              
185             my $ANON = 'a';
186              
187             sub get_anon {
188 5     5 0 8 my $self = shift;
189              
190             # HACK!!!
191 5         11 my $string = '___' . $ANON++;
192 5         11 $self->advance;
193 5         11 my $term = $self->{_vardict}{$string};
194 5 50       13 unless ($term) {
195 5         28 $term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum?
196 5         18 $self->{_vardict}{$string} = $term;
197             }
198 5         14 return ( $term, $string );
199             }
200              
201             # handle errors in one place
202             sub parseerror {
203 0     0 0 0 my ( $self, $character ) = @_;
204 0         0 my $linenum = $self->linenum;
205 0         0 croak "Unexpected character: ($character) at line number $linenum";
206             }
207              
208             # skips whitespace and prolog comments
209             sub skipspace {
210 4967     4967 0 5854 my $self = shift;
211 4967         8844 $self->advance while $self->current =~ /[[:space:]]/;
212 4967         9904 _skipcomment($self);
213             }
214              
215             # XXX Other subtle differences
216             sub _skipcomment {
217 4967     4967   6954 my $self = shift;
218 4967 100       7979 if ( $self->current eq '%' ) {
219 90   66     234 while ( $self->current ne "\n" && $self->current ne "#" ) {
220 3060         6076 $self->advance;
221             }
222 90         343 $self->skipspace;
223             }
224 4967 50       9565 if ( $self->current eq "/" ) {
225 0         0 $self->advance;
226 0 0       0 if ( $self->current ne "*" ) {
227 0         0 $self->parseerror("Expecting '*' after '/'");
228             }
229 0         0 $self->advance;
230 0   0     0 while ( $self->current ne "*" && $self->current ne "#" ) {
231 0         0 $self->advance;
232             }
233 0         0 $self->advance;
234 0 0       0 if ( $self->current ne "/" ) {
235 0         0 $self->parseerror("Expecting terminating '/' on comment");
236             }
237 0         0 $self->advance;
238 0         0 $self->skipspace;
239             }
240             }
241              
242             # reset the variable dictionary
243             sub nextclause {
244 394     394 0 518 my $self = shift;
245 394         760 $self->{_vardict} = {};
246 394         2262 $self->{_varnum} = 0;
247             }
248              
249             # takes a hash and extends it with the clauses in the string
250             # $program is a string representing a prolog program
251             # $db is an initial program that will be augmented with the
252             # clauses parsed.
253             # class method, not an instance method
254             sub consult {
255 22     22 0 99 my ( $class, $program, $db ) = @_;
256 22   66     190 $db ||= KnowledgeBase->new;
257 22         94 my $self = $class->new($program);
258 22         289 $self->linenum(1);
259 22         77 $self->skipspace;
260              
261 22         67 until ( $self->empty ) {
262 394         950 my $termlist = $self->_termlist;
263              
264 394         1078 my $head = $termlist->term;
265 394         993 my $body = $termlist->next;
266              
267 394   100     2670 my $is_primitive = $body && $body->isa(Primitive);
268 394 100       848 unless ($is_primitive) {
269 160         420 my $predicate = $head->predicate;
270 160         446 $is_primitive = exists $db->{primitives}{$predicate};
271             }
272 394 100       725 my $add = $is_primitive ? 'add_primitive' : 'add_clause';
273 394         1493 my $clause = Clause->new( $head, $body );
274 394         1386 my $adding_builtins = Engine->_adding_builtins;
275 394 100       1389 $clause->is_builtin(1) if $adding_builtins;
276 394         1411 $db->$add( $clause, $adding_builtins );
277 394         777 $self->skipspace;
278 394         894 $self->nextclause; # new set of vars
279             }
280 22         193 return $db;
281             }
282              
283             sub resolve {
284 0     0 0 0 my ( $class, $db ) = @_;
285 0         0 foreach my $termlist ( values %{ $db->ht } ) {
  0         0  
286 0         0 $termlist->resolve($db);
287             }
288             }
289              
290             sub _termlist {
291 401     401   538 my ($self) = @_;
292 401         1418 my $termlist = TermList->new;
293 401         1080 my @ts = $self->_term;
294 401         806 $self->skipspace;
295              
296 401 100       807 if ( $self->current eq ':' ) {
297 343         674 $self->advance;
298              
299 343 100       714 if ( $self->current eq '=' ) {
    50          
300              
301             # we're parsing a primitive
302 234         503 $self->advance;
303 234         482 $self->skipspace;
304 234         520 my $id = $self->getnum;
305 234         690 $self->skipspace;
306 234         477 $termlist->{term} = $ts[0];
307 234         935 $termlist->{next} = Primitive->new($id);
308             }
309             elsif ( $self->current ne '-' ) {
310 0         0 $self->parseerror("Expected '-' after ':'");
311             }
312             else {
313 109         221 $self->advance;
314 109         391 $self->skipspace;
315              
316 109         239 push @ts => $self->_term;
317 109         252 $self->skipspace;
318              
319 109         262 while ( $self->current eq ',' ) {
320 41         107 $self->advance;
321 41         115 $self->skipspace;
322 41         98 push @ts => $self->_term;
323 41         118 $self->skipspace;
324             }
325              
326 109         176 my @tsl;
327 109         312 for my $j ( reverse 1 .. $#ts ) {
328 150         664 $tsl[$j] = $termlist->new( $ts[$j], $tsl[ $j + 1 ] );
329             }
330              
331 109         219 $termlist->{term} = $ts[0];
332 109         231 $termlist->{next} = $tsl[1];
333             }
334             }
335             else {
336 58         116 $termlist->{term} = $ts[0];
337 58         103 $termlist->{next} = undef;
338             }
339              
340 401 50       961 if ( $self->current ne '.' ) {
341 0         0 $self->parseerror("Expected '.' Got '@{[$self->current]}'");
  0         0  
342             }
343 401         822 $self->advance;
344 401         871 return $termlist;
345             }
346              
347             # This constructor is the simplest way to construct a term. The term is given
348             # in standard notation.
349             # Example: my $term = Term->new(Parser->new("p(1,a(X,b))"));
350             sub _term {
351 1496     1496   2550 my ($self) = @_;
352 1496         4605 my $term = Term->new( undef, 0 );
353 1496         2590 my $ts = [];
354 1496         2227 my $i = 0;
355              
356 1496         3085 $self->skipspace; # otherwise we crash when we hit leading
357             # spaces
358 1496 100 66     2871 if ( $self->current =~ /^[[:lower:]'"]$/ ) {
    100          
    100          
    100          
    100          
    50          
359 692         1403 $term->{functor} = $self->getname;
360 692         1146 $term->{bound} = 1;
361 692         866 $term->{deref} = 0;
362              
363 692 100       2195 if ( '(' eq $self->current ) {
364 508         939 $self->advance;
365 508         1073 $self->skipspace;
366 508         1614 $ts->[ $i++ ] = $self->_term;
367 508         1079 $self->skipspace;
368              
369 508         1216 while ( ',' eq $self->current ) {
370 334         698 $self->advance;
371 334         685 $self->skipspace;
372 334         811 $ts->[ $i++ ] = $self->_term;
373 334         710 $self->skipspace;
374             }
375              
376 508 50       1034 if ( ')' ne $self->current ) {
377 0         0 $self->parseerror(
378 0         0 "Expecting: ')'. Got (@{[$self->current]})");
379             }
380              
381 508         1065 $self->advance;
382 508         1332 $term->{args} = [];
383              
384 508         2484 $term->{args}[$_] = $ts->[$_] for 0 .. ( $i - 1 );
385 508         986 $term->{arity} = $i;
386             }
387             else {
388 184         350 $term->{arity} = 0;
389             }
390             }
391             elsif ( $self->current =~ /^[[:upper:]]$/ ) {
392 674         997 $term->{bound} = 1;
393 674         856 $term->{deref} = 1;
394 674         1257 my ( $ref, $string ) = $self->getvar;
395 674         1165 $term->{ref} = $ref;
396 674         1202 $term->{varname} = $string;
397             }
398             elsif ( '_' eq $self->current && $self->peek =~ /^[\]\|\.;\s\,\)]$/ ) {
399              
400             # temporary hack to allow anonymous variables
401             # this should really be cleaned up
402 5         8 $term->{bound} = 1;
403 5         9 $term->{deref} = 1;
404 5         13 my ( $ref, $string ) = $self->get_anon;
405 5         9 $term->{ref} = $ref;
406 5         11 $term->{varname} = $string;
407             }
408             elsif ( $self->current =~ /^[-.[:digit:]]$/ ) {
409 75         158 return Number->new( $self->getnum );
410             }
411             elsif ( '[' eq $self->current ) {
412 23         52 $self->advance;
413              
414 23 100       51 if ( ']' eq $self->current ) {
415 3         12 $self->advance;
416 3         8 $term->{functor} = NULL;
417 3         5 $term->{arity} = 0;
418 3         7 $term->{bound} = 1;
419 3         5 $term->{deref} = 0;
420             }
421             else {
422 20         49 $self->skipspace;
423 20         103 $ts->[ $i++ ] = $self->_term;
424 20         55 $self->skipspace;
425              
426 20         51 while ( ',' eq $self->current ) {
427 25         68 $self->advance;
428 25         58 $self->skipspace;
429 25         67 $ts->[ $i++ ] = $self->_term;
430 25         66 $self->skipspace;
431             }
432              
433 20 100       149 if ( '|' eq $self->current ) {
434 11         35 $self->advance;
435 11         23 $self->skipspace;
436 11         31 $ts->[ $i++ ] = $self->_term;
437 11         35 $self->skipspace;
438             }
439             else {
440 9         36 $ts->[ $i++ ] = $term->new( NULL, 0 );
441             }
442              
443 20 50       57 if ( ']' ne $self->current ) {
444 0         0 $self->parseerror("Expecting ']'");
445             }
446              
447 20         48 $self->advance;
448 20         38 $term->{bound} = 1;
449 20         32 $term->{deref} = 0;
450 20         30 $term->{functor} = "cons";
451 20         43 $term->{arity} = 2;
452 20         52 $term->{args} = [];
453 20         76 for my $j ( reverse 1 .. $i - 2 ) {
454 25         76 my $term = $term->new( "cons", 2 );
455 25         96 $term->setarg( 0, $ts->[$j] );
456 25         73 $term->setarg( 1, $ts->[ $j + 1 ] );
457 25         59 $ts->[$j] = $term;
458             }
459 20         55 $term->{args}[0] = $ts->[0];
460 20         45 $term->{args}[1] = $ts->[1];
461             }
462             }
463             elsif ( '!' eq $self->current ) {
464 27         116 $self->advance;
465 27         141 return $term->CUT;
466             }
467             else {
468 0         0 $self->parseerror(
469 0         0 "Term should begin with a letter, a digit, or '[', not a @{[$self->current]}"
470             );
471             }
472 1394         3914 return $term;
473             }
474              
475             1;
476              
477             __END__