AI-Prolog
view release on metacpan or search on metacpan
0.63 Wed May 04, 2005
Allow parser to properly handle positive and negative numbers
and decimal points.
Added pow(X,Y).
Eliminated studlyCaps methods.
Added trace. and notrace.
Added a TODO test for a failing regression test.
0.62 Fri Feb 25, 2005
Added code to avoid bug in some Perl's where "undef" looks
like a number.
Major performance improvement. Now runs about 40% faster.
Added
listing.
println(X).
is(X,Y).
plus(X,Y).
minus(X,Y).
mult(X,Y).
div(X,Y).
lib/AI/Prolog.pm view on Meta::CPAN
Engine->formatted(0);
# Until (and unless) we figure out the weird bug that prevents some values
# binding in the external interface, we need to stick with this as the default
Engine->raw_results(1);
sub new {
my ( $class, $program ) = @_;
my $self = bless {
_prog => Parser->consult($program),
_query => undef,
_engine => undef,
} => $class;
lock_keys %$self;
return $self;
}
sub do {
my ( $self, $query ) = @_;
$self->query($query);
1 while $self->results;
$self;
lib/AI/Prolog.pm view on Meta::CPAN
Queries currently take the form of a valid prolog query but the final period
is optional:
$prolog->query('grandfather(Ancestor, julie).');
This method returns C<$self>.
=head2 C<results>
After a query has been issued, this method will return results satisfying the
query. When no more results are available, this method returns C<undef>.
while (my $result = $prolog->results) {
# [ 'grandfather', $ancestor, 'julie' ]
print "$result->[1] is a grandfather of julie.\n";
}
If C<raw_results> is false, the return value will be a "result" object with
methods corresponding to the variables. This is currently implemented as a
L<Hash::AsObject|Hash::AsObject> so the caveats with that module apply.
lib/AI/Prolog/Article.pod view on Meta::CPAN
In a regular expression, if a partial match is made, the regex engine remembers
where the end of that match occurred and tries to match more of the string. If
it fails, it backtracks to the last place a successful match was made and sees
if there are alternative matches it can try. If that fails, it keeps
backtracking to the last successful match and repeats that process until it
either finds a match or fails completely.
Unification, described in a fit of wild hand-waving, attempts to take two
logical terms and "unify" them. Imagine you have the following two lists:
( 1, 2, undef, undef, 5 )
( 1, 2, 3, 4, undef )
Imagine that undef means "unknown". We can unify those two lists because every
element that is known corresponds in the two lists. This leaves us with a list
of the integers one through five.
( 1, 2, 3, 4, 5 )
However, what happens if the last element of the first list is unknown?
( 1, 2, undef, undef, undef )
( 1, 2, 3, 4, undef )
We can still unify the two lists. In this case, we get the same five element
list, but the last item is unknown.
( 1, 2, 3, 4, undef )
If corresponding terms of the two lists are both bound (has a value) but not
equal, the lists will not unify:
( 1, 23, undef, undef, undef )
( 1, 2, 3, 4, undef )
Logic programming works by pushing these lists onto a stack and walking through
the stack and seeing if you can unify everything (sort of). But how to unify
from one item to the next? We assign names to the unknown values and see if
we can unify them. When we get to the next item in the stack, we check to see
if any named variables have been unified. If so, the engine will try to unify
them along with the other known variables.
That's a bad explanation, so here's how it works in Prolog. Imagine the
following knowledge base:
lib/AI/Prolog/Engine.pm view on Meta::CPAN
}
sub new {
my ( $class, $term, $prog ) = @_;
my $self = bless {
# The stack holds choicepoints and a list of variables
# which need to be un-bound upon backtracking.
_stack => [],
_db => KnowledgeBase->new,
_goal => TermList->new( $term, undef ), # TermList
_call => $term, # Term
_run_called => undef,
_cp => undef,
_retract_clause => undef,
_trace => 0, # whether or not tracing is done
_halt => 0, # will stop the aiprolog shell
_perlpackage => undef,
_step_flag => undef,
} => $class;
lock_keys %$self;
# to add a new primitive, use the binding operator (:=) to assign a unique
# index to the primitive and add the corresponding definition to
# @PRIMITIVES.
eval {
$self->_adding_builtins(1);
$self->{_db} = Parser->consult( <<' END_PROG', $prog );
ne(X, Y) :- not(eq(X,Y)).
lib/AI/Prolog/Engine.pm view on Meta::CPAN
croak("Engine->new failed. Cannot parse default program: $@");
}
$self->{_retract_clause} = $self->{_db}->get("retract/1");
$self->{_goal}->resolve( $self->{_db} );
return $self;
}
sub query {
my ( $self, $query ) = @_;
$self->{_stack} = [];
$self->{_run_called} = undef;
$self->{_goal} = TermList->new($query);
$self->{_call} = $query;
$self->{_goal}->resolve( $self->{_db} );
return $self;
}
sub _stack { shift->{_stack} }
sub _db { shift->{_db} }
sub _goal { shift->{_goal} }
sub _call { shift->{_call} }
lib/AI/Prolog/Engine.pm view on Meta::CPAN
? $results[1]
: $results[0];
}
}
unless ( $self->{_goal} && $self->{_goal}{term} ) {
croak("Engine->run fatal error. goal->term is null!");
}
unless ( $self->{_goal}->{next_clause} ) {
my $predicate = $self->{_goal}{term}->predicate;
_warn("WARNING: undefined predicate ($predicate)\n");
next if $self->backtrack; # if we backtracked, try again
return; # otherwise, we failed
}
my $clause = $self->{_goal}->{next_clause};
if ( my $next_clause = $clause->{next_clause} ) {
push @{ $self->{_stack} } => $self->{_cp}
= ChoicePoint->new( $self->{_goal}, $next_clause, );
}
my $vars = [];
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
}
push @pod => $line;
}
push @pod => '=cut';
# XXX I hate instantiating this here, but there
# appears to be a bug in parsing if I don't :(
my $parser = Pod::Simple::Text->new;
my $output;
$parser->output_string( \$output );
$parser->parse_lines( @pod, undef );
$DESCRIPTION_FOR{$predicate} = $output;
$output = '';
}
}
}
return;
}
sub _remove_choices {
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
# Search the call stack...
if ( not defined $function_ref ) {
my $cx = 1;
my %packages;
CX:
while ( my $package = caller $cx ) {
# Don't retry packages...
next if exists $packages{$package};
$packages{$package} = undef;
# AUTOLOAD using packages are expected to provide a
# ->can() that works. I don't know if that's a widely
# known expectation but it's what I'm going to go
# with. Hash::AsObject gets this wrong.
if (do {
no strict 'refs'; ## no critic NoStrict
defined &{"$package\::$function_name"};
}
or $package->can($function_name)
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
}
}
# We got nuthin! Damn! I'll try for the first AUTOLOAD.
if ( not defined $function_ref ) {
my $cx = 1;
my %packages;
AUTOLOAD_CX:
while ( my ($package) = caller $cx ) {
next if exists $packages{$package};
$packages{$package} = undef;
if (do {
no strict 'refs'; ## no critic NoStrict
defined &{"$package\::AUTOLOAD"};
}
or $package->can('AUTOLOAD')
)
{
$function_ref = "$package\::$function_name";
last AUTOLOAD_CX;
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
continue {
++$cx;
}
}
if ( not defined $function_ref ) {
return FAIL;
}
# XXX What do to with the first arg?
my ( undef, $results_ref ) = $term->getarg(1)->to_data;
my @results = @{ $results_ref->[0] };
eval {
no strict 'refs'; ## no critic NoStrict
$function_ref->(@results);
};
if ( my $e = $@ ) {
# Extreme caution here.
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
}
$c->next_clause($clause);
}
}
sub assert {
my ( $self, $term ) = @_;
$term = $term->clean_up;
# XXX whoops. Need to check exact semantics in Term
my $newC = Clause->new( $term->deref, undef );
my $predicate = $term->predicate;
if ( $self->{primitives}{$predicate} ) {
carp("Trying to assert a primitive: $predicate");
return;
}
my $c = $self->{ht}{$predicate};
if ($c) {
while ( $c->next_clause ) {
$c = $c->next_clause;
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
}
sub asserta {
my ( $self, $term ) = @_;
my $predicate = $term->predicate;
if ( $self->{primitives}{$predicate} ) {
carp("Trying to assert a primitive: $predicate");
return;
}
$term = $term->clean_up;
my $newC = Clause->new( $term->deref, undef );
my $c = $self->{ht}{$predicate};
$newC->next_clause($c);
$self->{ht}{$predicate} = $newC;
}
sub retract {
my ( $self, $term, $stack ) = @_;
my $newC = Clause->new( $term, undef ); #, undef);
my $predicate = $term->predicate;
if ( exists $self->{primitives}{$predicate} ) {
carp("Trying to retract a primitive: $predicate");
return;
}
my $cc;
my $c = $self->{ht}{$predicate};
while ($c) {
my $vars = [];
lib/AI/Prolog/Parser.pm view on Meta::CPAN
for my $j ( reverse 1 .. $#ts ) {
$tsl[$j] = $termlist->new( $ts[$j], $tsl[ $j + 1 ] );
}
$termlist->{term} = $ts[0];
$termlist->{next} = $tsl[1];
}
}
else {
$termlist->{term} = $ts[0];
$termlist->{next} = undef;
}
if ( $self->current ne '.' ) {
$self->parseerror("Expected '.' Got '@{[$self->current]}'");
}
$self->advance;
return $termlist;
}
# This constructor is the simplest way to construct a term. The term is given
# in standard notation.
# Example: my $term = Term->new(Parser->new("p(1,a(X,b))"));
sub _term {
my ($self) = @_;
my $term = Term->new( undef, 0 );
my $ts = [];
my $i = 0;
$self->skipspace; # otherwise we crash when we hit leading
# spaces
if ( $self->current =~ /^[[:lower:]'"]$/ ) {
$term->{functor} = $self->getname;
$term->{bound} = 1;
$term->{deref} = 0;
lib/AI/Prolog/Parser/PreProcessor/Math.pm view on Meta::CPAN
# XXX I should probably cache the string and show it.
# XXX But it doesn't matter because that shouldn't happen here
croak(
"Parse error in math pre-processor. Mismatched parens"
);
}
$last = $i;
$tokens->[$first] = $class->_parse_group(
[ @{$tokens}[ $first + 1 .. $last - 1 ] ] );
undef $tokens->[$_] for $first + 1 .. $last;
@$tokens = grep $_ => @$tokens;
undef $first;
undef $last;
redo REDUCE;
}
}
$parens_left = 0 unless defined $first;
}
return _as_string( $class->_parse_group($tokens) );
}
sub _parse_group {
my ( $class, $tokens ) = @_;
lib/AI/Prolog/Parser/PreProcessor/Math.pm view on Meta::CPAN
for my $i ( 0 .. $#$tokens ) {
my $token = $tokens->[$i];
if ( ref $token && "@$token" =~ /OP ($op_re)/ ) {
my $curr_op = $1;
my $prev = _prev_token( $tokens, $i );
my $next = _next_token( $tokens, $i );
$tokens->[$i] = sprintf
"%s(%s, %s)" => $convert{$curr_op},
_as_string( $tokens->[$prev] ),
_as_string( $tokens->[$next] );
undef $tokens->[$prev];
undef $tokens->[$next];
}
}
@$tokens = grep $_ => @$tokens;
}
#main::diag Dumper $tokens;
return $tokens->[0]; # should never have more than on token left
}
sub _prev_token {
lib/AI/Prolog/Term.pm view on Meta::CPAN
sub _new_from_string {
my ( $class, $string ) = @_;
my $parsed = Parser->new($string)->_term($class);
}
sub _new_var {
my $class = shift;
#print "*** _new_var @{[$VARNUM+1]}";
my $self = bless {
functor => undef,
arity => 0,
args => [],
# if bound is false, $self is a reference to a free variable
bound => 0,
varid => $VARNUM++,
# if bound and deref are both true, $self is a reference to a ref
deref => 0,
ref => undef,
ID => undef,
varname => undef,
_results => undef,
#source => "_new_var",
} => $class;
lock_keys %$self;
return $self;
}
sub _new_with_id {
my ( $class, $id ) = @_;
#print "*** _new_with_id: $id";
my $self = bless {
functor => undef,
arity => 0,
args => [],
# if bound is false, $self is a reference to a free variable
bound => 0,
varid => $id,
# if bound and deref are both true, $self is a reference to a ref
deref => 0,
ref => undef,
varname => undef,
ID => undef,
_results => undef,
#source => "_new_with_id: $id",
} => $class;
lock_keys %$self;
return $self;
}
sub _new_from_functor_and_arity {
my ( $class, $functor, $arity ) = @_;
my $print_functor = defined $functor ? $functor : 'null';
confess "undefined arity" unless defined $arity;
#print "*** _new_from_functor_and_arity: ($print_functor) ($arity)";
my $self = bless {
functor => $functor,
arity => $arity,
args => [],
# if bound is false, $self is a reference to a free variable
bound => 1,
varid => 0, # XXX ??
# if bound and deref are both true, $self is a reference to a ref
deref => 0,
ref => undef,
varname => undef,
ID => undef,
_results => undef,
#source => "_new_from_functor_and_arity: ($print_functor) ($arity)",
} => $class;
lock_keys %$self;
return $self;
}
sub varnum {$VARNUM} # class method
sub functor { shift->{functor} }
sub arity { shift->{arity} }
lib/AI/Prolog/Term.pm view on Meta::CPAN
croak( "AI::Prolog::Term->bind("
. $self->to_string
. "). Cannot bind to nonvar!" );
}
}
# unbinds a term -- i.e., resets it to a variable
sub unbind {
my $self = shift;
$self->{bound} = 0;
$self->{ref} = undef;
# XXX Now possible for a bind to have had no effect so ignore safety test
# XXX if (bound) bound = false;
# XXX else IO.error("Term.unbind","Can't unbind var!");
}
# set specific arguments. A primitive way of constructing terms is to
# create them with Term(s,f) and then build up the arguments. Using the
# parser is much simpler
sub setarg {
lib/AI/Prolog/Term.pm view on Meta::CPAN
push @results => $args[$i]->_to_data($parent);
}
# I have no idea what the following line was doing.
#push @results => $args[$arity - 1]->_to_data($parent)
}
}
return @results;
}
} # else unbound;
return undef;
}
my %varname_for;
my $varname = 'A';
sub to_string {
require Data::Dumper;
my $self = shift;
return $self->_to_string(@_);
}
lib/AI/Prolog/TermList.pm view on Meta::CPAN
#my ($proto, $parser, $nexttermlist, $definertermlist) = @_;
my $proto = shift;
my $class = ref $proto || $proto; # yes, I know what I'm doing
return _new_from_term( $class, @_ ) if 1 == @_ && $_[0]->isa(Term);
return _new_from_term_and_next( $class, @_ ) if 2 == @_;
if (@_) {
croak "Unknown arguments to TermList->new: @_";
}
my $self = bless {
term => undef,
next => undef,
next_clause =>
undef, # serves two purposes: either links clauses in database
# or points to defining clause for goals
is_builtin => undef,
varname => undef,
ID => undef,
_results => undef,
} => $class;
lock_keys %$self;
return $self;
}
sub _new_from_term {
my ( $class, $term ) = @_;
my $self = $class->new;
$self->{term} = $term;
return $self;
ok $@, 'Calling new with arguments it does not expect should croak()';
like $@, qr/Unknown arguments to Term->new/,
'... with an appropriate error message';
# new, unbound term
ok my $term = $CLASS->new, 'Calling it without arguments should succeed';
isa_ok $term, $CLASS, '... and the object it returns';
#diag $term->to_string;
my $term2 = $term->refresh([undef, $term]);
#diag $term2->to_string;
can_ok $term, 'functor';
ok ! defined $term->functor, '... and creating an blank term should not have a functor';
can_ok $term, 'arity';
is $term->arity, 0, '... and the blank term should have an arity (number of args) of 0';
can_ok $term, 'args';
is_deeply $term->args, [], '... and it should have no args';
t/50engine.t view on Meta::CPAN
'... calling it the first time should provide the first unification';
is $engine->results, 'append([a], [b,c,d], [a,b,c,d])',
'... and then the second unification';
is $engine->results, 'append([a,b], [c,d], [a,b,c,d])',
'... and then the third unification';
is $engine->results, 'append([a,b,c], [d], [a,b,c,d])',
'... and then the fifth unification';
is $engine->results, 'append([a,b,c,d], [], [a,b,c,d])',
'... and then the last unification unification';
ok ! defined $engine->results,
'... and it should return undef when there are no more results';
my $bootstrapped_db = clone($database);
$query = Term->new('append(X,[d],[a,b,c,d]).');
can_ok $engine, 'query';
$engine->query($query);
is $engine->results,'append([a,b,c], [d], [a,b,c,d])',
'... and it should let us issue a new query against the same db';
ok !$engine->results, '... and it should not return spurious results';
t/50engine.t view on Meta::CPAN
$result = $engine->results;
is_deeply $result->X, [qw/a b c/], '... and the X result should be correct';
is_deeply $result->Y, [qw/d/], '... and the Y result should be correct';
$result = $engine->results;
is_deeply $result->X, [qw/a b c d/], '... and the X result should be correct';
is_deeply $result->Y, [], '... and the Y result should be correct';
ok ! defined ($result = $engine->results),
'... and results() should return undef when there are no more results';
can_ok $CLASS, 'raw_results';
$CLASS->raw_results(1);
$CLASS->formatted(0);
$engine->query(Term->new('append(X,Y,[a,b,c,d])'));
is_deeply $engine->results, ['append', [], [qw/a b c d/], [qw/a b c d/]],
'... and subsequent results should match expectations';
is_deeply $engine->results, ['append', [qw/a/], [qw/b c d/], [qw/a b c d/]],
'... and subsequent results should match expectations';
is_deeply $engine->results, ['append', [qw/a b/], [qw/c d/], [qw/a b c d/]],
'... and subsequent results should match expectations';
is_deeply $engine->results, ['append', [qw/a b c/], [qw/d/], [qw/a b c d/]],
'... and subsequent results should match expectations';
is_deeply $engine->results, ['append', [qw/a b c d/], [], [qw/a b c d/]],
'... and subsequent results should match expectations';
ok ! defined $engine->results,
'... and it should return undef when there are no more results'
t/99regression.t view on Meta::CPAN
[ 'c', 'a' ],
[ 'c', 'b' ]
);
is_deeply \@results, \@expected, 'The .62 unify bug should be bye-bye';
my $faux_engine = Test::MockModule->new(Engine);
my @stdout;
$faux_engine->mock(_warn => sub { push @stdout => @_ });
$prolog->query('no_such_predicate(X).');
$prolog->results;
like $stdout[0], qr{WARNING: undefined predicate \(no_such_predicate/1\)},
'Non-existent predicates should warn';
( run in 2.252 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )