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