File Coverage

lib/AI/Prolog/Term.pm
Criterion Covered Total %
statement 212 273 77.6
branch 91 138 65.9
condition 43 73 58.9
subroutine 38 46 82.6
pod 0 30 0.0
total 384 560 68.5


line stmt bran cond sub pod time code
1             package AI::Prolog::Term;
2             $REVISION = '$Id: Term.pm,v 1.10 2005/08/06 23:28:40 ovid Exp $';
3            
4             $VERSION = '0.07';
5 13     13   85003 use strict;
  13         31  
  13         463  
6 13     13   82 use warnings;
  13         26  
  13         473  
7 13     13   65 use Carp qw( croak confess );
  13         26  
  13         897  
8            
9 13     13   4976 use Hash::Util 'lock_keys';
  13         11732  
  13         78  
10            
11 13     13   1851 use aliased 'AI::Prolog::Term::Cut';
  13         939  
  13         119  
12 13     13   974 use aliased 'AI::Prolog::Parser';
  13         25  
  13         58  
13            
14 13     13   1472 use aliased 'Hash::AsObject';
  13         29  
  13         53  
15            
16 13     13   27068 use constant NULL => 'null';
  13         27  
  13         51019  
17            
18             # Var is a type of term
19             # A term is a basic data structure in Prolog
20             # There are three types of terms:
21             # 1. Values (i.e., have a functor and arguments)
22             # 2. Variables (i.e., unbound)
23             # 3. References (bound to another variable)
24            
25             my $VARNUM = 1;
26            
27             # controls where occurcheck is used in unification.
28             # In early Java versions, the occurcheck was always performed
29             # which resulted in lower performance.
30            
31             my $OCCURCHECK = 0;
32            
33             sub occurcheck {
34 309     309 0 2897 my ( $class, $value ) = @_;
35 309 100       624 $OCCURCHECK = $value if defined $value;
36 309         1231 return $OCCURCHECK;
37             }
38            
39             # controls printing of lists as [a,b]
40             # instead of cons(a, cons(b, null))
41            
42 359     359 0 492 sub prettyprint {1}
43            
44             my $CUT = Cut->new(0);
45 86     86 0 439 sub CUT {$CUT}
46            
47             sub new {
48 2464     2464 0 4582 my $proto = shift;
49 2464   66     8516 my $class = CORE::ref $proto || $proto; # yes, I know what I'm doing
50 2464 100       5234 return $class->_new_var unless @_;
51 2191 100       4865 if ( 2 == @_ ) { # more common (performance)
    100          
52 1651 50       5349 return _new_from_functor_and_arity( $class, @_ )
53             unless 'ARRAY' eq CORE::ref $_[1];
54             }
55             elsif ( 1 == @_ ) {
56 539         620 my $arg = shift;
57 539 100 66     3784 return _new_with_id( $class, $arg )
58             if !CORE::ref $arg && $arg =~ /^[[:digit:]]+$/;
59 41 50       164 return _new_from_string( $class, $arg ) if !CORE::ref $arg;
60            
61             #return $arg->_term($class) if CORE::ref $arg && $arg->isa(Parser);
62             }
63 1         206 croak("Unknown arguments to Term->new");
64             }
65            
66             sub _new_from_string {
67 41     41   80 my ( $class, $string ) = @_;
68 41         196 my $parsed = Parser->new($string)->_term($class);
69             }
70            
71             sub _new_var {
72 273     273   343 my $class = shift;
73            
74             #print "*** _new_var @{[$VARNUM+1]}";
75 273         1958 my $self = bless {
76             functor => undef,
77             arity => 0,
78             args => [],
79            
80             # if bound is false, $self is a reference to a free variable
81             bound => 0,
82             varid => $VARNUM++,
83            
84             # if bound and deref are both true, $self is a reference to a ref
85             deref => 0,
86             ref => undef,
87            
88             ID => undef,
89             varname => undef,
90             _results => undef,
91            
92             #source => "_new_var",
93             } => $class;
94 273         772 lock_keys %$self;
95 273         2601 return $self;
96             }
97            
98             sub _new_with_id {
99 498     498   3880 my ( $class, $id ) = @_;
100            
101             #print "*** _new_with_id: $id";
102 498         4326 my $self = bless {
103             functor => undef,
104             arity => 0,
105             args => [],
106            
107             # if bound is false, $self is a reference to a free variable
108             bound => 0,
109             varid => $id,
110            
111             # if bound and deref are both true, $self is a reference to a ref
112             deref => 0,
113             ref => undef,
114            
115             varname => undef,
116             ID => undef,
117             _results => undef,
118            
119             #source => "_new_with_id: $id",
120             } => $class;
121 498         1631 lock_keys %$self;
122 498         4592 return $self;
123             }
124            
125             sub _new_from_functor_and_arity {
126 1901     1901   2962 my ( $class, $functor, $arity ) = @_;
127 1901 100       3505 my $print_functor = defined $functor ? $functor : 'null';
128 1901 50       10589 confess "undefined arity" unless defined $arity;
129            
130             #print "*** _new_from_functor_and_arity: ($print_functor) ($arity)";
131 1901         16016 my $self = bless {
132             functor => $functor,
133             arity => $arity,
134             args => [],
135            
136             # if bound is false, $self is a reference to a free variable
137             bound => 1,
138             varid => 0, # XXX ??
139             # if bound and deref are both true, $self is a reference to a ref
140             deref => 0,
141             ref => undef,
142            
143             varname => undef,
144             ID => undef,
145             _results => undef,
146            
147             #source => "_new_from_functor_and_arity: ($print_functor) ($arity)",
148             } => $class;
149 1901         6385 lock_keys %$self;
150 1901         26962 return $self;
151             }
152            
153 0     0 0 0 sub varnum {$VARNUM} # class method
154 1265     1265 0 3526 sub functor { shift->{functor} }
155 1511     1511 0 3307 sub arity { shift->{arity} }
156 86     86 0 267 sub args { shift->{args} }
157 52     52 0 221 sub varid { shift->{varid} }
158 262     262 0 813 sub ref { shift->{ref} }
159 668     668 0 1577 sub predicate { sprintf "%s/%d" => $_[0]->getfunctor, $_[0]->getarity }
160            
161             sub deref {
162 36     36 0 53 my $self = shift;
163 36   100     187 while ( $self->{bound} && $self->{deref} ) {
164 19         59 $self = $self->{ref};
165             }
166 36         96 return $self;
167             }
168            
169             sub bound {
170 37     37 0 57 my $self = shift;
171 37   66     170 while ( $self->{bound} && $self->{deref} ) {
172 0         0 $self = $self->{ref};
173             }
174 37         198 return $self->{bound};
175             }
176            
177 26     26 0 54 sub is_bound { shift->bound }
178            
179             sub traceln {
180 0     0 0 0 my ( $self, $msg ) = @_;
181 0 0       0 if ( $self->{trace} ) {
182 0         0 print "$msg\n";
183             }
184             }
185            
186             sub dup {
187 0     0 0 0 my $self = shift;
188 0         0 $self->new( $self->{functor}, $self->{arity} );
189             }
190            
191             # bind a variable to a term
192             sub bind {
193 324     324 0 425 my ( $self, $term ) = @_;
194 324 50       1602 return if $self eq $term;
195 324 50       644 unless ( $self->{bound} ) {
196 324         440 $self->{bound} = 1;
197 324         402 $self->{deref} = 1;
198 324         819 $self->{ref} = $term;
199             }
200             else {
201 0         0 croak( "AI::Prolog::Term->bind("
202             . $self->to_string
203             . "). Cannot bind to nonvar!" );
204             }
205             }
206            
207             # unbinds a term -- i.e., resets it to a variable
208             sub unbind {
209 201     201 0 243 my $self = shift;
210 201         318 $self->{bound} = 0;
211 201         692 $self->{ref} = undef;
212            
213             # XXX Now possible for a bind to have had no effect so ignore safety test
214             # XXX if (bound) bound = false;
215             # XXX else IO.error("Term.unbind","Can't unbind var!");
216             }
217            
218             # set specific arguments. A primitive way of constructing terms is to
219             # create them with Term(s,f) and then build up the arguments. Using the
220             # parser is much simpler
221             sub setarg {
222 50     50 0 78 my ( $self, $pos, $val ) = @_;
223 50 50 33     228 if ( $self->{bound} && !$self->{deref} ) {
224 50         141 $self->{args}[$pos] = $val;
225             }
226             else {
227 0         0 croak( "AI::Prolog::Term->setarg($pos, "
228             . $val->to_string
229             . "). Cannot setarg on variables!" );
230             }
231             }
232            
233             # retrieves an argument of a term
234             sub getarg {
235 811     811 0 1083 my ( $self, $pos ) = @_;
236            
237             # should check if position is valid
238 811 50       1487 if ( $self->{bound} ) {
239 811 100       4567 return $self->{ref}->getarg($pos) if $self->{deref};
240 733         3136 return $self->{args}[$pos];
241             }
242             else {
243 0         0 croak("AI::Prolog::Term->getarg. Error -- lookup on unbound term!");
244             }
245             }
246            
247             sub getfunctor {
248 1252     1252 0 1515 my $self = shift;
249 1252 50       2748 return "" unless $self->{bound};
250 1252 100       2548 return $self->{ref}->getfunctor if $self->{deref};
251 1160         4016 return $self->{functor};
252             }
253            
254             sub getarity {
255 1140     1140 0 1298 my $self = shift;
256 1140 50       5172 return 0 unless $self->{bound};
257 1140 100       2365 return $self->{ref}->getarity if $self->{deref};
258 1073         4990 return $self->{arity};
259             }
260            
261             # check whether a variable occurs in a term
262             # XXX Since a variable is not consideref to occur in itself,
263             # XXX added occurs1 and a new front end called occurs()
264             sub occurs {
265 0     0 0 0 my ( $self, $var ) = @_;
266 0 0       0 return if $self->{varid} == $var;
267 0         0 return $self->occurs1($var);
268             }
269            
270             sub occurs1 {
271 0     0 0 0 my ( $self, $var ) = @_;
272 0 0       0 if ( $self->{bound} ) {
273 0 0       0 return $self->ref->occurs1($var) if $self->{deref};
274 0         0 for my $i ( 0 .. $self->arity - 1 ) {
275 0 0       0 return 1 if $self->{args}[$i]->occurs1($var);
276             }
277             }
278             else {
279 0         0 return $self->varid == $var;
280             }
281             }
282            
283             # used internally for debugging
284             sub _dumpit {
285 0     0   0 local $^W;
286 0         0 my $self = shift;
287 0   0     0 my $indent = shift || '';
288 0         0 print( $indent . "source: ", $self->{source} );
289 0 0       0 print( $indent . "bound: ", ( $self->{bound} ? 'true' : 'false' ) );
290 0   0     0 print( $indent . "functor: ", ( $self->{functor} || 'null' ) );
291 0 0       0 if ( !$self->{ref} ) {
292 0         0 print( $indent . "ref: null" );
293             }
294             else {
295 0         0 print( "\n$indent" . "ref:" );
296 0         0 $self->{ref}->_dumpit( $indent . ' ' );
297             }
298 0         0 print( $indent . "arity: ", $self->{arity} );
299 0 0       0 if ( defined $self->{args}[0] ) {
300 0         0 print( $indent. "args:" );
301 0         0 foreach ( @{ $self->{args} } ) {
  0         0  
302 0         0 $_->_dumpit( $indent . " " );
303             }
304             }
305             else {
306 0         0 print( $indent. "args: null" );
307             }
308            
309             #print($indent . "args: ", scalar @{$self->{args}}) if defined $self->{args}[0];
310 0 0       0 print( $indent . "deref: ", ( $self->{deref} ? 'true' : 'false' ) );
311 0         0 print( $indent . "varid: ", $self->{varid}, "\n" );
312             }
313            
314             # Unification is the basic primitive operation in logic programming.
315             # $stack: the stack is used to store the address of variables which
316             # are bound by the unification. This is needed when backtracking.
317            
318             sub unify {
319 476     476 0 655 my ( $self, $term, $stack ) = @_;
320            
321             #_dumpit($self);
322             #_dumpit($term);
323            
324 476         794 foreach ( $self, $term ) {
325 952   100     5016 $_ = $_->{ref} while $_->{bound} and $_->{deref};
326             }
327            
328 476 100 100     1729 if ( $self->{bound} and $term->{bound} ) { # bound and not deref
329 176 100 66     348 if ( $self->functor eq $term->getfunctor
330             && $self->arity == $term->getarity )
331             {
332 164         356 for my $i ( 0 .. $self->arity - 1 ) {
333             return
334 350 100       881 unless $self->{args}[$i]
335             ->unify( $term->getarg($i), $stack );
336             }
337 147         588 return 1;
338             }
339             else {
340 12         64 return; # functor/arity don't match ...
341             }
342             } # at least one arg not bound ...
343 300 100       654 if ( $self->{bound} ) {
344            
345             # added missing occurcheck
346 58 50       157 if ( $self->occurcheck ) {
347 0 0       0 if ( $self->occurs( $term->varid ) ) {
348 0         0 return;
349             }
350             }
351 58         137 $term->bind($self);
352 58         73 push @{$stack} => $term; # side-effect -- setting stack vars
  58         137  
353 58         239 return 1;
354             }
355            
356             # do occurcheck if turned on
357 242 50 33     486 return if $self->occurcheck && $term->occurs( $self->varid );
358 242         515 $self->bind($term);
359 242         255 push @{$stack} => $self; # save for backtracking
  242         426  
360 242         744 return 1;
361             }
362            
363             # refresh creates new variables. If the variables already exist
364             # in its arguments then they are used. This is used when parsing
365             # a clause so that variables throughout the clause are shared.
366             # Includes a copy operation.
367            
368             sub refresh {
369 1183     1183 0 1505 my ( $self, $term_aref ) = @_;
370 1183 100       2673 if ( $self->{bound} ) {
371 745 100       1638 if ( $self->{deref} ) {
372 437         996 return $self->{ref}->refresh($term_aref);
373             }
374             else {
375 308 100       755 if ( 0 == $self->{arity} ) {
376 58         186 return $self;
377             }
378             else {
379 250         838 my $term = ( CORE::ref $self)
380             ->_new_from_functor_and_arity( $self->{functor},
381             $self->{arity} );
382 250         662 for my $i ( 0 .. $self->{arity} - 1 ) {
383 562         6058 $term->{args}[$i]
384             = $self->{args}[$i]->refresh($term_aref);
385             }
386 250         919 return $term;
387             }
388             }
389             }
390            
391             # else unbound
392 438 100       1001 unless ( $term_aref->[ $self->{varid} ] ) {
393 272         499 $term_aref->[ $self->{varid} ] = $self->new;
394             }
395 438         1734 return $term_aref->[ $self->{varid} ];
396             }
397            
398             sub to_data {
399 15     15 0 29 my $self = shift;
400 15         40 $self->{_results} = {};
401            
402             # @results is the full results, if we ever need it
403 15         79 my @results = $self->_to_data($self);
404 15         205 return AsObject->new( $self->{_results} ), \@results;
405             }
406            
407             sub _to_data {
408 353     353   512 my ( $self, $parent ) = @_;
409 353 100       801 if ( defined $self->{varname} ) {
410            
411             # XXX here's where the [HEAD|TAIL] bug is. The engine works fine,
412             # but we can't bind TAIL to a result object and are forced to
413             # switch to raw_results.
414 26         72 my $varname = delete $self->{varname};
415 26         85 ( $parent->{_results}{$varname} ) = $self->_to_data($parent);
416 26         79 $self->{varname} = $varname;
417             }
418 353 100       791 if ( $self->{bound} ) {
419 349         636 my $functor = $self->functor;
420 349         686 my $arity = $self->arity;
421 349 100       880 return $self->ref->_to_data($parent) if $self->{deref};
422 209 100 66     663 return [] if NULL eq $functor && !$arity;
423 201 100 66     678 if ( "cons" eq $functor && 2 == $arity ) {
424 46         152 my @result = $self->{args}[0]->_to_data($parent);
425 46         106 my $term = $self->{args}[1];
426            
427 46   66     132 while ( "cons" eq $term->getfunctor && 2 == $term->getarity ) {
428 86 100       199 if ( $term->{varname} ) {
429 1         5 push @result => $term->_to_data($parent);
430             } else {
431 85         180 push @result => $term->getarg(0)->_to_data($parent);
432             }
433 86         194 $term = $term->getarg(1);
434             }
435            
436             # XXX Not really sure about this one
437 46 50 33     106 push @result => $term->_to_data($parent)
438             unless NULL eq $term->getfunctor && !$term->getarity;
439            
440             # ? "]"
441             # : "|" . $term->_to_data($parent) . "]";
442 46         225 return \@result;
443             }
444             else {
445 155         333 my @results = $self->functor;
446 155 100       313 if ( $self->arity ) {
447            
448             #push @results => [];
449 15         39 my $arity = $self->arity;
450 15         24 my @args = @{ $self->args };
  15         42  
451 15 50       49 if (@args) {
452 15         37 for my $i ( 0 .. $arity - 1 ) {
453 40         140 push @results => $args[$i]->_to_data($parent);
454             }
455            
456             # I have no idea what the following line was doing.
457             #push @results => $args[$arity - 1]->_to_data($parent)
458             }
459             }
460 155         549 return @results;
461             }
462             } # else unbound;
463 4         10 return undef;
464             }
465            
466             my %varname_for;
467             my $varname = 'A';
468            
469             sub to_string {
470 51     51 0 42733 require Data::Dumper;
471 51         55531 my $self = shift;
472 51         251 return $self->_to_string(@_);
473             }
474            
475             sub _to_string {
476 380     380   529 my ( $self, $extended ) = @_;
477 380 100       879 if ( $self->{bound} ) {
478 359         660 my $functor = $self->functor;
479 359         685 my $arity = $self->arity;
480 359         682 my $prettyprint = $self->prettyprint;
481 359 100       1130 return $self->ref->_to_string($extended) if $self->{deref};
482 246 50 66     970 return "[]" if NULL eq $functor && !$arity && $prettyprint;
      66        
483 242         252 my $string;
484 242 100 66     851 if ( "cons" eq $functor && 2 == $arity && $prettyprint ) {
      66        
485 29         89 $string = "[" . $self->{args}[0]->_to_string;
486 29         61 my $term = $self->{args}[1];
487            
488 29   66     68 while ( "cons" eq $term->getfunctor && 2 == $term->getarity ) {
489 59         138 $string .= "," . $term->getarg(0)->_to_string;
490 59         143 $term = $term->getarg(1);
491             }
492            
493             $string .=
494 29 50 33     65 ( NULL eq $term->getfunctor && !$term->getarity )
495             ? "]"
496             : "|" . $term->_to_string . "]";
497 29         107 return "$string";
498             }
499             else {
500 213         394 $string = $self->functor;
501 213 100       408 if ( $self->arity ) {
502 61         92 $string .= "(";
503 61 50       116 if ( $self->arity ) {
504 61         92 local $Data::Dumper::Terse = 1; # don't use $var1
505 61         103 local $Data::Dumper::Indent = 0; # no newline
506 128         367 my @args = map {
507 61         139 my $string = $_->_to_string;
508 128 100 100     685 $string =~ /\s/
509             && !$_->arity
510             ? Data::Dumper::Dumper($string)
511             : $string;
512 61         70 } @{ $self->args };
513 61         387 $string .= join ", " => @args;
514             }
515 61         90 $string .= ")";
516             }
517             }
518 213         782 return $string;
519             } # else unbound;
520             # return "_" . $self->varid;
521 21   66     99 my $var = $self->{varname} || $varname_for{ $self->varid } || $varname++;
522 21         50 $varname_for{ $self->varid } = $var;
523 21         70 return $var;
524             }
525            
526             # ----------------------------------------------------------
527             # Copy a term to put in the database
528             # - with new variables (freshly renumbered)
529             # ----------------------------------------------------------
530            
531             # XXX XProlog
532             my %CVDICT;
533             my $CVN;
534            
535             sub clean_up {
536 0     0 0 0 my $self = shift;
537 0         0 %CVDICT = ();
538 0         0 $CVN = 0;
539 0         0 return $self->_clean_up;
540             }
541            
542             sub _clean_up {
543 0     0   0 my $self = shift;
544 0         0 my $term;
545 0 0       0 if ( $self->{bound} ) {
546 0 0 0     0 if ( $self->{deref} ) {
    0          
547 0         0 return $self->{ref}->_clean_up;
548             }
549             elsif ( defined $self->{arity} && 0 == $self->{arity} ) {
550 0         0 return $self;
551             }
552             else {
553 0         0 $term = $self->dup;
554 0         0 for my $i ( 0 .. $self->{arity} - 1 ) {
555 0         0 $term->{args}[$i] = $self->{args}[$i]->_clean_up;
556             }
557             }
558             }
559             else { # unbound
560 0         0 $term = $CVDICT{$self};
561 0 0       0 unless ($term) {
562 0         0 $term = $self->new( $CVN++ );
563 0         0 $CVDICT{$self} = $term; # XXX Should this be $self->to_string?
564             }
565             }
566 0         0 return $term;
567             }
568            
569             # From XProlog
570             sub value {
571            
572             # int i, res = 0;
573 46     46 0 53 my $self = shift;
574 46         58 my ( $i, $res ) = ( 0, 0 );
575            
576 46 100       121 unless ( $self->{bound} ) {
577 1         3 my $term = $self->to_string;
578 1         223 croak("Tried to to get value of unbound term ($term)");
579             }
580 45 100       141 return $self->{ref}->value if $self->{deref};
581 21         40 my $functor = $self->getfunctor;
582 21         44 my $arity = $self->getarity;
583 21 50 33     63 if ( 'rnd' eq $functor && 1 == $arity ) {
584            
585             # implement rand
586             }
587 21 50       61 if ( $arity < 2 ) {
588 0         0 my $term = $self->to_string;
589 0         0 croak("Term ($term) is not binary");
590             }
591 21         63 my $arg0 = $self->{args}[0]->value;
592 21         57 my $arg1 = $self->{args}[1]->value;
593            
594 21 100       54 return $arg0 + $arg1 if 'plus' eq $functor;
595 17 100       51 return $arg0 - $arg1 if 'minus' eq $functor;
596 11 100       39 return $arg0 * $arg1 if 'mult' eq $functor;
597 5 100       17 return $arg0 / $arg1 if 'div' eq $functor;
598 4 100       15 return $arg0 % $arg1 if 'mod' eq $functor;
599 3 50       42 return $arg0**$arg1 if 'pow' eq $functor;
600 0           croak("Unknown operator ($functor)");
601             }
602            
603             1;
604            
605             __END__