AI-Prolog
view release on metacpan or search on metacpan
bin/aiprolog view on Meta::CPAN
warn $@;
next;
}
$RESULTS = 1;
show_results($prolog);
while ($MORE && user_wants_more()) {
show_results($prolog);
}
}
sub show_results {
return unless $RESULTS;
my ($prolog) = @_;
my $results = $prolog->results;
$results ||= ''; # otherwise it's an arrayref
print $OUT $results, " ";
unless ($results) {
print $OUT "No\n";
$RESULTS = 0;
}
}
sub user_wants_more {
return unless $RESULTS;
ReadMode 'cbreak';
my $key = ReadKey(0);
ReadMode 'normal';
if (';' eq $key) {
print $OUT ";\n\n";
return 1;
}
print $OUT "\n\nYes\n" if $RESULTS;
return;
}
my $offset;
sub help {
$offset ||= tell DATA;
seek DATA, $offset, 0;
pod2usage({
-verbose => 2,
-input => \*DATA,
-exitval => 'NOEXIT',
});
}
__DATA__
examples/benchmark.pl view on Meta::CPAN
for (1 .. 10) {
$prolog->query('nrev30.');
while (my $result = $prolog->results) {
print $_,' ',@$result,$/;
}
}
my $t1 = new Benchmark;
my $td = timediff($t1, $t0);
print "the code took:",timestr($td),"\n";
sub benchmark {
return <<" END_BENCHMARK";
append([],X,X).
append([X|Xs],Y,[X|Z]) :-
append(Xs,Y,Z).
nrev([],[]).
nrev([X|Xs],Zs) :-
nrev(Xs,Ys),
append(Ys,[X],Zs).
nrev30 :-
nrev([1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0],X).
examples/data_structures.pl view on Meta::CPAN
printf "badguy steals %s from %s\n"
=> $result->GOODS, $result->VICTIM;
}
AI::Prolog::Engine->raw_results(1);
$logic->query('steals(badguy, GOODS, VICTIM).');
while (my $result = $logic->results) {
print Dumper($result);
}
sub thief_prog {
return <<' END_PROG';
steals(PERP, STUFF, VICTIM) :-
thief(PERP),
valuable(STUFF),
owns(VICTIM,STUFF),
not(knows(PERP,VICTIM)).
thief(badguy).
valuable(gold).
valuable(rubies).
owns(merlyn,gold).
examples/path.pl view on Meta::CPAN
$prolog->query('solve( p(2,2), L).') if $query == 3;
my $t0 = new Benchmark;
#$prolog->trace(1);
my $results = $prolog->results;
print Dumper($results);
my $t1 = new Benchmark;
my $td = timediff($t1, $t0);
print "the code took:",timestr($td),"\n";
sub path_prog {
return <<' END_PROG';
solve(Dest,L) :-
solve(p(1,1), Dest, L).
solve(S, Dest, Sol) :-
path(S, Dest, [S], Path),
invert(Path, Sol).
path( P, P, L, L).
path( Node, Goal, Path, Sol) :-
arc( Node, Node2), not( wall(Node2) ),
examples/trace.pl view on Meta::CPAN
END_MESSAGE
<STDIN>;
$logic->do('notrace.');
$logic->query('steals("Bad guy", STUFF, VICTIM)');
while (my $results = $logic->results) {
printf "Bad guy steals %s from %s\n",
$results->STUFF, $results->VICTIM;
}
sub thief_prog {
return <<' END_PROG';
steals(PERP, STUFF, VICTIM) :-
thief(PERP),
valuable(STUFF),
owns(VICTIM,STUFF),
not(knows(PERP,VICTIM)).
thief("Bad guy").
valuable(gold).
valuable(rubies).
owns(merlyn,gold).
lib/AI/Prolog.pm view on Meta::CPAN
use Text::Quote;
use Regexp::Common;
# they don't want pretty printed strings if they're using this interface
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;
}
sub query {
my ( $self, $query ) = @_;
# make that final period optional
$query .= '.' unless $query =~ /\.$/;
$self->{_query} = Term->new($query);
unless ( defined $self->{_engine} ) {
# prime the pump
$self->{_engine} = Engine->new( @{$self}{qw/_query _prog/} );
}
$self->{_engine}->query( $self->{_query} );
return $self;
}
sub results {
my $self = shift;
unless ( defined $self->{_query} ) {
croak "You can't fetch results because you have not set a query";
}
$self->{_engine}->results;
}
sub trace {
my $self = shift;
if (@_) {
$self->{_engine}->trace(shift);
return $self;
}
return $self->{_engine}->trace;
}
sub raw_results {
my $class = shift;
if (@_) {
Engine->raw_results(shift);
return $class;
}
return Engine->raw_results;
}
my $QUOTER;
sub quote {
my ( $proto, $string ) = @_;
$QUOTER = Text::Quote->new unless $QUOTER;
return $QUOTER->quote_simple($string);
}
sub list {
my $proto = shift;
return
join ", " => map { /^$RE{num}{real}$/ ? $_ : $proto->quote($_) } @_;
}
sub continue {
my $self = shift;
return 1 unless $self->{_engine}; # we haven't started yet!
!$self->{_engine}->halt;
}
1;
__END__
=head1 NAME
lib/AI/Prolog/Article.pod view on Meta::CPAN
functional, objective, and logical programming styles has one or more
conceptual blindspots. It's like knowing how to boil but not fry.
Programming is not a skill one develops in five easy lessons.
-- Tom Christiansen
By now, many Perl programmers know that the language offers support for
imperative, objective, and functional programming. However, logic programming
seems to be a lost art. This article attempts to shed a little light on the
subject. It's not that Prolog can do things that Perl cannot or vice versa.
Instead, Prolog does some things more naturally than Perl -- and vice versa.
In fact, while I introduce you to Prolog, I won't be teaching a bunch of nifty
tricks to make your Perl more powerful. I can't say what needs you may have
and, in any event, the tools that allow logic programming in Perl are generally
alpha quality, thus making them unsuitable for production environments.
=head2 What is Logic Programming?
Logic programming is somewhat of a mystery to many Perl programmers because,
unlike imperative, objective, and functional styles, Perl does not have direct
lib/AI/Prolog/Article.pod view on Meta::CPAN
gives(tom, book, sally).
B<Note:> While the order of the arguments is technically not relevant, there
is a convention to more or less read the arguments left to right. The above
fact can be read as "tom gives the book to sally." Of course, it is sometimes
read as "sally gives the book to tom", but whichever order you adopt, you must
keep it consistent.
A fact consists of a I<functor> (also known as the I<head>) and 0 or more
arguments, followed by a period. Allowed names for functors generally follow
allowed named for subroutines in Perl.
The number of arguments to the functor are known as the I<arity>. The functor,
followed by a slash and the arity ("gives/3" in this example) is called the
I<predicate>. A predicate can have as many clauses as you like.
gives(tom, book, sally).
gives(tom, book, martin).
gives('George Bush', grief, liberals).
gives('Bill Clinton', grief, conservatives).
lib/AI/Prolog/Article.pod view on Meta::CPAN
$prolog->query($some_query);
And do something with the results:
while ( my $results = $prolog->results ) {
print "@$results\n";
}
Results are usually each returned as an array reference with the first argument
being the functor and subsequent arguments being the values. If any value is a
list, it will be represented as an array reference. We'll see more on that
later as we cover lists.
Now let's see the full program:
#!/usr/bin/perl
use strict;
use warnings;
use AI::Prolog;
lib/AI/Prolog/Article.pod view on Meta::CPAN
Why does that work? Well, going back to the C<member/2> predicate, we can find
out if a term is an element of a list:
member(ovid, SOMELIST).
Or we can find all members of a list:
member(X, SOMELIST). % assumes SOMELIST is bound to a list
Now that might seem kind of nifty, but appending lists in Prolog is truly
sublime. Many consider understanding the power of the C<append/3> predicate
the true gateway to appreciating logic programming. So, without further ado:
append([], X, X).
append([HEAD|X], Y, [HEAD|Z]) :-
append(X, Y, Z).
You'll probably want to put that in a file named I<append.pro> and in the
shell C<consult('append.pro')> to follow along with some of the examples
you're about to see.
lib/AI/Prolog/Article.pod view on Meta::CPAN
Perhaps the most significant is the depth-first exhaustive search algorithm
used for deduction. This is slow and due to the dynamically typed nature of
Prolog, many of the optimizations that have been applied to databases cannot be
applied to Prolog. Many Prolog programmers, understanding how the language
works internally, use the "cut" operator, C<!> (an exclamation point), to prune
the search trees. This leads to our next problem.
The "cut" operator is what is known as an "extra-logical" predicate. This,
along with I/O and predicates that assert and retract facts in the database
are a subject of much controversy. They cause issues because they frequently
cannot be backtracked over and the order of the clauses sometimes becomes
important when using them. They can be very useful and simplify many problems,
but they are more imperative in nature than logical and can introduce subtle
bugs.
Math is also handled poorly in Prolog. Consider the following program:
convert(Celsius, Fahrenheit) :-
Celsius is (Fahrenheit - 32) * 5 / 9.
You can then issue the query C<convert(Celsuis, 32)> and it will dutifully
report that the celsius value is zero. However, C<convert(0, 32)> fails. This
is because Prolog is not able to solve the right hand side of the equation
lib/AI/Prolog/Builtins.pod view on Meta::CPAN
=over 4
=item Improve printing.
There are some bugs with printing and escaping characters. Maybe I'll look
into them :)
=item More builtins.
Currently, we only have a tiny subset of builtins available. More are coming.
=back
=head1 MATH
Since version .70, math is fully available in C<AI::Prolog>. Note that math is
implemented via the
L<AI::Prolog::Parser::PreProcessor::Math|AI::Prolog::Parser::PreProcessor::Math>
module. This module rewrites Prolog math to an internal, predicate-based form
with the L<AI::Prolog::Parser|AI::Prolog::Parser> can parse. This may cause
lib/AI/Prolog/ChoicePoint.pm view on Meta::CPAN
package AI::Prolog::ChoicePoint;
$REVISION = '$Id: ChoicePoint.pm,v 1.5 2005/02/20 18:27:55 ovid Exp $';
$VERSION = '0.02';
use strict;
use warnings;
use Hash::Util 'lock_keys';
sub new {
my ( $class, $goal, $clause ) = @_;
my $self = bless {
goal => $goal,
clause => $clause,
} => $class;
lock_keys %$self;
return $self;
}
sub goal { $_[0]->{goal} }
sub clause { $_[0]->{clause} }
sub to_string {
my $self = shift;
return " ||" . $self->clause->to_string . "|| ";
}
1;
__END__
=head1 NAME
lib/AI/Prolog/Cookbook.pod view on Meta::CPAN
reverse(List, Reverse) :-
reverse_accumulate(List, [], Reverse).
reverse_accumulate([], List, List).
reverse_accumulate([Head|Tail], Accumulate, Reverse) :-
reverse_accumulate(Tail, [Head|Accumulate], Reverse).
Reversing a list is tricky. If this predicate were written in an imperative
manner, it might look something like this:
sub reverse {
my @list = @_;
my @reverse;
while (my $element = shift @list) {
unshift @reverse, $element;
}
return @reverse;
}
This method of reversing a list runs in C<O(n)> time. However, new Prolog
programmers often write what is known as the "naive reverse" which uses the
lib/AI/Prolog/Cookbook.pod view on Meta::CPAN
naive reverse is frequently used as a benchmarking tool for logic programs.
If reversing a 30 element list via the naive reverse takes .1 seconds, we can
say that the Prolog implementation is running at about 5000 logical inferences
per second. This is known by the unfortunate acronym of LIPS, the standard
measure of the speed of logic programs. Modern Prolog implementations
frequently measure their performance in MLIPS, or MegaLIPS. By contrast, the
human mind is frequently estimated to run between 1 to 4 LIPS. This
demonstrates that there's much more to cognition than logic.
=head2 Checking if a list is a subset of another list.
Usage: C<subset(Subset, List).>
This definition depends on the C<member/2> predicate defined in this document.
subset([Head|Tail], List) :-
member(Head, List),
subset(Tail, List).
subset([], _). % The empty list is a subset of all lists
=head2 Delete all occurences of a term from a list, giving a new list.
Usage: C<delete(Term, List, Result).>
delete(_,[],[]). % deleting anything from an empty list yields an empty list
delete(Term, [Term|Tail], Result) :-
delete(Term, Tail, Result).
delete(Term, [Head|Tail], [Head|TailResult]) :-
delete(Term, Tail, TailResult).
lib/AI/Prolog/Engine.pm view on Meta::CPAN
use constant OnceMark => 'OnceMark';
# The engine is what executes prolog queries.
# Author emeritus: Dr. Michael Winikoff
# Translation to Perl: Curtis "Ovid" Poe
# $prog An initial program - this will be extended
# $term The query to be executed
# This governs whether tracing is done
sub trace {
my $self = shift;
if (@_) {
$self->{_trace} = shift;
return $self;
}
return $self->{_trace};
}
sub halt {
my $self = shift;
if (@_) {
$self->{_halt} = shift;
return $self;
}
return $self->{_halt};
}
my $FORMATTED = 1;
sub formatted {
my $self = shift;
if (@_) {
$FORMATTED = shift;
return $self;
}
return $FORMATTED;
}
my $RAW_RESULTS;
sub raw_results {
my $self = shift;
if (@_) {
$RAW_RESULTS = shift;
if ($RAW_RESULTS) {
$self->formatted(0);
}
return $self;
}
return $RAW_RESULTS;
}
my $BUILTIN = 0;
sub _adding_builtins {
my $self = shift;
if (@_) {
$BUILTIN = shift;
return $self;
}
return $BUILTIN;
}
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,
lib/AI/Prolog/Engine.pm view on Meta::CPAN
$self->_adding_builtins(0);
};
if ($@) {
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} }
sub dump_goal {
my ($self) = @_;
if ( $self->{_goal} ) {
_print( "\n= Goals: " . $self->{_goal}->to_string );
_print(
"\n==> Try: " . $self->{_goal}->next_clause->to_string . "\n" )
if $self->{_goal}->next_clause;
}
else {
_print("\n= Goals: null\n");
}
}
sub results {
my $self = shift;
if ( $self->{_run_called} ) {
return unless $self->backtrack;
}
else {
$self->{_run_called} = 1;
}
$self->_run;
}
sub _run {
my ($self) = @_;
my $stackTop = 0;
while (1) {
$stackTop = @{ $self->{_stack} };
if ( $self->{_goal} && $self->{_goal}->isa(Step) ) {
$self->{_goal} = $self->{_goal}->next;
if ( $self->{_goal} ) {
$self->{_goal}->resolve( $self->{_db} );
lib/AI/Prolog/Engine.pm view on Meta::CPAN
$self->{_goal} = $p1;
$self->{_goal}->resolve( $self->{_db} );
}
}
else { # unify failed. Must backtrack
return unless $self->backtrack;
}
}
}
sub backtrack {
my $self = shift;
_print(" <<== Backtrack: \n") if $self->{_trace};
while ( @{ $self->{_stack} } ) {
my $o = pop @{ $self->{_stack} };
if ( UNIVERSAL::isa( $o, Term ) ) {
$o->unbind;
}
elsif ( UNIVERSAL::isa( $o, ChoicePoint ) ) {
$self->{_goal} = $o->{goal};
# XXX This could be very dangerous if we accidentally try
# to assign a term to itself! See ChoicePoint->next_clause
$self->{_goal}->next_clause( $o->{clause} );
return 1;
}
}
return;
}
sub _print { # convenient testing hook
print @_;
}
sub _warn { # convenient testing hook
warn @_;
}
use constant RETURN => 2;
sub do_primitive { # returns false if fails
my ( $self, $term, $c ) = @_;
my $primitive = AI::Prolog::Engine::Primitives->find( $c->ID )
or die sprintf "Cannot find primitive for %s (ID: %d)\n",
$term->to_string, $c->ID;
return unless my $result = $primitive->( $self, $term, $c );
return 1 if RETURN == $result;
$self->{_goal} = $self->{_goal}->next;
if ( $self->{_goal} ) {
$self->{_goal}->resolve( $self->{_db} );
}
lib/AI/Prolog/Engine.pm view on Meta::CPAN
AI::Prolog::Engine->raw_results(1);
$engine->query('steals(badguy, STUFF, VICTIM).');
while (my $r = $engine->results) {
# do stuff with $r in the form:
# ['steals', 'badguy', $STUFF, $VICTIM]
}
=head2 C<query($query)>
If you already have an engine object instantiated, call the C<query()> method
for subsequent queries. Internally, when calling C<new()>, the engine
bootstraps a set of Prolog predicates to provide the built ins. However, this
process is slow. Subsequent queries to the same engine with the C<query()>
method can double the speed of your program.
my $engine = Engine->new($query, $database);
while (my $results = $engine->results) {
print $results, $/;
}
$query = Term->new("steals(ovid, X).");
$engine->query($query);
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
use aliased 'AI::Prolog::Term';
use aliased 'AI::Prolog::Term::Cut';
use aliased 'AI::Prolog::Term::Number';
use aliased 'AI::Prolog::TermList';
use aliased 'AI::Prolog::TermList::Step';
use aliased 'AI::Prolog::ChoicePoint';
my %DESCRIPTION_FOR;
my $LONGEST_PREDICATE = '';
sub _load_builtins {
return if keys %DESCRIPTION_FOR;
require Pod::Simple::Text;
require Pod::Perldoc;
my $perldoc = Pod::Perldoc->new;
my $builtin_pod = 'AI::Prolog::Builtins';
my ($found) = $perldoc->grand_search_init( [$builtin_pod] )
or die "Help failed. Cannot find documentation for $builtin_pod: $!";
open my $fh, '<', $found
or die "Cannot open $found for reading: ($!)";
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
$parser->parse_lines( @pod, undef );
$DESCRIPTION_FOR{$predicate} = $output;
$output = '';
}
}
}
return;
}
sub _remove_choices {
# this implements the cut operator
my ( $self, $varid ) = @_;
my @stack;
my $i = @{ $self->{_stack} };
while ( $i > $varid ) {
my $o = pop @{ $self->{_stack} };
if ( not $o->isa(ChoicePoint) ) {
push @stack => $o;
}
$i--;
}
while (@stack) {
push @{ $self->{_stack} } => pop @stack;
}
return;
}
sub _splice_goal_list {
my ( $self, $term ) = @_;
my ( $t2, $p, $p1, $ptail );
my @vars;
my $i = 0;
$term = $term->getarg(0);
while ( $term && $term->getfunctor ne 'null' ) {
$t2 = $term->getarg(0);
if ( $t2 eq Term->CUT ) {
$p = TermList->new( Cut->new( scalar @{ $self->{_stack} } ) );
}
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
$self->{_goal}->resolve( $self->{_db} );
return;
}
use constant CONTINUE => 1;
use constant RETURN => 2;
use constant FAIL => ();
my @PRIMITIVES; # we'll fix this later
$PRIMITIVES[1] = sub { # !/0 (cut)
my ( $self, $term, $c ) = @_;
_remove_choices( $self, $term->varid );
CONTINUE;
};
$PRIMITIVES[2] = sub { # call/1
my ( $self, $term, $c ) = @_;
$self->{_goal} = TermList->new( $term->getarg(0), $self->{_goal}->next );
$self->{_goal}->resolve( $self->{_db} );
RETURN;
};
$PRIMITIVES[3] = sub { # fail/0
FAIL;
};
$PRIMITIVES[4] = sub { # consult/1
my ( $self, $term, $c ) = @_;
my $file = $term->getarg(0)->getfunctor;
if ( open my $fh, '<', $file ) {
# Avoid do { local $/; <$fh> }. This triggers a bug where
# *two* copies of the string are made. Double space is
# required.
my $prolog;
{
local $/;
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
}
$self->{_db}->consult($prolog);
return CONTINUE;
}
else {
warn "Could not open ($file) for reading: $!";
return FAIL;
}
};
$PRIMITIVES[5] = sub { # assert/1
my ( $self, $term, $c ) = @_;
$self->{_db}->assert( $term->getarg(0) );
return CONTINUE;
};
$PRIMITIVES[7] = sub { # retract/1
my ( $self, $term, $c ) = @_;
if ( not $self->{_db}->retract( $term->getarg(0), $self->{_stack} ) ) {
$self->backtrack;
return FAIL;
}
$self->{_cp}->clause( $self->{_retract_clause} )
; # if $self->{_cp}; # doesn't work
return CONTINUE;
};
$PRIMITIVES[8] = sub { # listing/0
my $self = shift;
$self->{_db}->dump(0);
return CONTINUE;
};
$PRIMITIVES[9] = sub { # listing/1
my ( $self, $term, $c ) = @_;
my $predicate = $term->getarg(0)->getfunctor;
$self->{_db}->list($predicate);
return CONTINUE;
};
$PRIMITIVES[10] = sub { # print/1
my ( $self, $term, $c ) = @_;
AI::Prolog::Engine::_print( $term->getarg(0)->to_string );
return CONTINUE;
};
$PRIMITIVES[11] = sub { # println/1
my ( $self, $term, $c ) = @_;
AI::Prolog::Engine::_print( $term->getarg(0)->to_string . "\n" );
return CONTINUE;
};
$PRIMITIVES[12] = sub { AI::Prolog::Engine::_print("\n"); CONTINUE }; # nl
$PRIMITIVES[13] = sub { # trace. notrace.
my ( $self, $term ) = @_;
$self->{_trace} = $term->getfunctor eq 'trace';
AI::Prolog::Engine::_print(
'Trace ' . ( $self->{_trace} ? 'ON' : 'OFF' ) );
return CONTINUE;
};
$PRIMITIVES[15] = sub { # is/2
my ( $self, $term, $c ) = @_;
my $rhs = $term->getarg(0)->deref;
my $lhs = $term->getarg(1)->value;
if ( $rhs->is_bound ) {
my $value = $rhs->value;
if ( not looks_like_number($value) ) {
return FAIL;
}
return $value == $lhs;
}
$rhs->bind( Number->new($lhs) );
push @{ $self->{_stack} } => $rhs;
return CONTINUE;
};
$PRIMITIVES[16] = sub { # gt/2
my ( $self, $term ) = @_;
return ( $term->getarg(0)->value > $term->getarg(1)->value )
? CONTINUE
: FAIL;
};
$PRIMITIVES[17] = sub { # lt/2
my ( $self, $term ) = @_;
return ( $term->getarg(0)->value < $term->getarg(1)->value )
? CONTINUE
: FAIL;
};
$PRIMITIVES[19] = sub { # ge/2
my ( $self, $term ) = @_;
return ( $term->getarg(0)->value >= $term->getarg(1)->value )
? CONTINUE
: FAIL;
};
$PRIMITIVES[20] = sub { # le/2
my ( $self, $term ) = @_;
return ( $term->getarg(0)->value <= $term->getarg(1)->value )
? CONTINUE
: FAIL;
};
$PRIMITIVES[22] = sub { # halt/0
my ( $self, $term ) = @_;
$self->halt(1);
CONTINUE;
};
$PRIMITIVES[23] = sub { # var/1
my ( $self, $term, $c ) = @_;
return $term->getarg(0)->bound() ? FAIL : CONTINUE;
};
# plus(X,Y) := 25.
# minux(X,Y) := 26.
# mult(X,Y) := 27.
# div(X,Y) := 28.
# mod(X,Y) := 29.
$PRIMITIVES[30] = sub { # seq/1
my ( $self, $term, $c ) = @_;
$self->_splice_goal_list($term);
CONTINUE;
};
my $HELP_OUTPUT;
$PRIMITIVES[31] = sub { # help/0
_load_builtins();
if ( not $HELP_OUTPUT ) {
$HELP_OUTPUT = "Help is available for the following builtins:\n\n";
my @predicates = sort keys %DESCRIPTION_FOR;
my $length = length $LONGEST_PREDICATE;
my $columns = 5;
my $format = join ' ' => ("%-${length}s") x $columns;
while (@predicates) {
my @row;
for ( 1 .. $columns ) {
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
}
$HELP_OUTPUT .= sprintf $format => @row;
$HELP_OUTPUT .= "\n";
}
$HELP_OUTPUT .= "\n";
}
AI::Prolog::Engine::_print($HELP_OUTPUT);
CONTINUE;
};
$PRIMITIVES[32] = sub { # help/1
my ( $self, $term, $c ) = @_;
my $predicate = $term->getarg(0)->to_string;
_load_builtins();
if ( my $description = $DESCRIPTION_FOR{$predicate} ) {
AI::Prolog::Engine::_print($description);
}
else {
AI::Prolog::Engine::_print("No help available for ($predicate)\n\n");
$PRIMITIVES[31]->();
}
CONTINUE;
};
my $gensym_int = 0;
$PRIMITIVES[33] = sub { # gemsym/1
my ( $self, $term, $c ) = @_;
my $t2 = Term->new( 'v' . $gensym_int++, 0 );
return $t2->unify( $term->getarg(0), $self->{_stack} )
? CONTINUE
: FAIL;
};
use constant UNDEFINED_SUBROUTINE_ERROR => do {
eval {
no strict 'refs'; ## no critic NoStrict
&{'---'};
};
my $e = $@;
# Undefined subroutine &main::--- called at .../Primitives.pm line 12.
my ($msg) = $e =~ / \A
(.+) # 'Undefined subroutine'
(?<=\s) # ' '
\S* # &main::
---/mx
or die q[Perl's error message changed! Damn! Fix this regex.];
$msg;
};
$PRIMITIVES[34] = sub { # perlcall2/2
my ( $self, $term ) = @_;
# Get a function name...
my $function_term = $term->getarg(0);
if ( not $function_term->is_bound ) {
return FAIL;
}
my $function_name = $function_term->to_string;
# Lookup a fully qualified function name...
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
# Extreme caution here.
if ( $e =~ UNDEFINED_SUBROUTINE_ERROR ) {
return FAIL;
}
}
return CONTINUE;
};
sub find { return $PRIMITIVES[ $_[1] ] }
1;
__END__
=head1 NAME
AI::Prolog::Engine::Primitives - The code for running aiprolog builtins
=head1 SYNOPSIS
my $builtin = AI::Prolog::Engine::Primitives ->find($builtin_id);
=head1 DESCRIPTION
This module contains the code to handle the built-in predicates. The
L<AI::Prolog::Engine|AI::Prolog::Engine> assigns many builtins an ID
number and this number is used to lookup the sub necessary to execute
the built-in.
=head1 AUTHOR
Curtis "Ovid" Poe, E<lt>moc tod oohay ta eop_divo_sitrucE<gt>
Reverse the name to email me.
=head1 COPYRIGHT AND LICENSE
lib/AI/Prolog/Introduction.pod view on Meta::CPAN
use Data::Dumper;
my $prolog = AI::Prolog->new(append_prog());
$prolog->raw_results(0) # Disable raw results
$prolog->query("append(X,Y,[a,b,c,d])");
while (my $result = $prolog->results) {
print Dumper($result->X); # array references
print Dumper($result->Y);
}
sub append_prog {
return <<' END_PROLOG';
append([], X, X).
append([W|X],Y,[W|Z]) :- append(X,Y,Z).
END_PROLOG
}
=head1 SEE ALSO
W-Prolog: L<http://goanna.cs.rmit.edu.au/~winikoff/wp/>
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
use strict;
use warnings;
use Carp qw( confess carp );
use Hash::Util 'lock_keys';
use aliased 'AI::Prolog::Engine';
use aliased 'AI::Prolog::Parser';
use aliased 'AI::Prolog::TermList::Clause';
sub new {
my $self = bless {
ht => {},
primitives => {}, # only uses keys
oldIndex => "",
} => shift;
lock_keys %$self;
return $self;
}
sub ht { shift->{ht} } # temp hack XXX
sub to_string {
my $self = shift;
return "{"
. (
join ', ' => map { join '=' => $_->[0], $_->[1] }
sort { $a->[2] <=> $b->[2] }
map { [ $_, $self->_sortable_term( $self->{_vardict}{$_} ) ] }
keys %{ $self->{ht} }
) . "}";
}
sub _sortable_term {
my ( $self, $term ) = @_;
my $string = $term->to_string;
my $number = substr $string => 1;
return $string, $number;
}
sub put {
my ( $self, $key, $termlist ) = @_;
$self->{ht}{$key} = $termlist;
}
sub elements { [ values %{ shift->{ht} } ] }
sub reset {
my $self = shift;
$self->{ht} = {};
$self->{primitives} = {};
$self->{oldIndex} = '';
}
sub consult {
my ( $self, $program ) = @_;
$self->{oldIndex} = '';
return Parser->consult( $program, $self );
}
sub add_primitive {
my ( $self, $clause ) = @_;
my $term = $clause->term;
my $predicate = $term->predicate;
my $c = $self->{ht}{$predicate};
if ($c) {
while ( $c->next_clause ) {
$c = $c->next_clause;
}
$c->next_clause($clause);
}
else {
$self->{primitives}{$predicate} = 1;
$self->{ht}{$predicate} = $clause;
}
}
sub add_clause {
my ( $self, $clause ) = @_;
my $term = $clause->term;
my $predicate = $term->predicate;
if ( $self->{primitives}{$predicate} ) {
carp("Trying to modify primitive predicate: $predicate");
return;
}
unless ( $predicate eq $self->{oldIndex} ) {
delete $self->{ht}{$predicate};
$self->{ht}{$predicate} = $clause;
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
}
else {
my $c = $self->{ht}{$predicate};
while ( $c->next_clause ) {
$c = $c->next_clause;
}
$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;
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
while ( $c->next_clause ) {
$c = $c->next_clause;
}
$c->next_clause($newC);
}
else {
$self->{ht}{$predicate} = $newC;
}
}
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};
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
for ( my $i = @{$stack} - $top; $i > 0; $i-- ) {
my $t = pop @{$stack};
$t->unbind;
}
$cc = $c;
$c = $c->next_clause;
}
return;
}
sub retractall {
my ( $self, $term, $arity ) = @_;
my $predicate = $term->predicate;
if ( $self->{primitives}{$predicate} ) {
carp("Trying to retractall primitives: $predicate");
return;
}
delete $self->{ht}{$predicate};
return 1;
}
sub get {
my ( $self, $term ) = @_;
my $key = ref $term ? $term->to_string : $term;
return $self->{ht}{$key};
}
sub set {
my ( $self, $term, $value ) = @_;
my $key = ref $term ? $term->to_string : $term;
$self->{ht}{$key} = $value->clean_up;
}
sub _print { print @_ }
sub dump {
my ( $self, $full ) = @_;
my $i = 1;
while ( my ( $key, $value ) = each %{ $self->{ht} } ) {
next if !$full && ( $self->{primitives}{$key} || $value->is_builtin );
if ( $value->isa(Clause) ) {
_print( $i++ . ". $key: \n" );
do {
_print( " " . $value->term->to_string );
if ( $value->next ) {
_print( " :- " . $value->next->to_string );
lib/AI/Prolog/KnowledgeBase.pm view on Meta::CPAN
$value = $value->next_clause;
} while ($value);
}
else {
_print( $i++ . ". $key = $value\n" );
}
}
_print("\n");
}
sub list {
my ( $self, $predicate ) = @_;
print "\n$predicate: \n";
my $head = $self->{ht}{$predicate}
or warn "Cannot list unknown predicate ($predicate)";
while ($head) {
print " " . $head->term->to_string;
if ( $head->next ) {
print " :- " . $head->next->to_string;
}
print ".\n";
lib/AI/Prolog/Parser.pm view on Meta::CPAN
use aliased 'AI::Prolog::Term';
use aliased 'AI::Prolog::Term::Number';
use aliased 'AI::Prolog::TermList';
use aliased 'AI::Prolog::TermList::Clause';
use aliased 'AI::Prolog::TermList::Primitive';
my $ATOM = qr/[[:alpha:]][[:alnum:]_]*/;
use constant NULL => 'null';
sub new {
my ( $class, $string ) = @_;
my $self = bless {
_str => PreProcessor->process($string),
_posn => 0,
_start => 0,
_varnum => 0,
_internal => 0,
_vardict => {},
} => $class;
lock_keys %$self;
return $self;
}
sub _vardict_to_string {
my $self = shift;
return "{"
. (
join ', ' => map { join '=' => $_->[0], $_->[1] }
sort { $a->[2] <=> $b->[2] }
map { [ $_, $self->_sortable_term( $self->{_vardict}{$_} ) ] }
keys %{ $self->{_vardict} }
) . "}";
}
sub _sortable_term {
my ( $self, $term ) = @_;
my $string = $term->to_string;
my $number = substr $string => 1;
return $string, $number;
}
sub to_string {
my $self = shift;
my $output = Clone::clone($self);
$output->{_vardict} = $self->_vardict_to_string;
return "{"
. substr( $self->{_str}, 0, $self->{_posn} ) . " ^ "
. substr( $self->{_str}, $self->{_posn} ) . " | "
. $self->_vardict_to_string . " }";
}
sub _posn { shift->{_posn} }
sub _str { shift->{_str} }
sub _start { shift->{_start} }
sub _varnum { shift->{_varnum} }
sub _vardict { shift->{_vardict} }
sub _internal {
my $self = shift;
if (@_) {
$self->{_internal} = shift;
return $self;
}
return $self->{_internal};
}
# get the current character
sub current {
my $self = shift;
return '#' if $self->empty;
return substr $self->{_str} => $self->{_posn}, 1;
}
# peek at the next character
sub peek {
my $self = shift;
return '#' if $self->empty;
return substr( $self->{_str} => ( $self->{_posn} + 1 ), 1 ) || '#';
}
# is the parsestring empty?
sub empty {
my $self = shift;
return $self->{_posn} >= length $self->{_str};
}
my $LINENUM = 1;
sub linenum {
my $self = shift;
if (@_) {
$LINENUM = shift;
return $self;
}
$LINENUM;
}
sub advance_linenum {
my $self = shift;
$LINENUM++;
}
# Move a character forward
sub advance {
my $self = shift;
# print $self->current; # XXX
$self->{_posn}++ unless $self->{_posn} >= length $self->{_str};
$self->advance_linenum if $self->current =~ /[\r\n]/;
}
# all three get methods must be called before advance
# recognize a name (sequence of alphanumerics)
# XXX the java methods do not directly translate, so
# we need to revisit this if it breaks
# XXX Update: There was a subtle bug. I think
# I've nailed it, though. The string index was off by one
sub getname {
my $self = shift;
$self->{_start} = $self->{_posn};
my $getname;
if ( $self->current =~ /['"]/ ) {
# Normally, Prolog distinguishes between single and double quoted strings
my $string = substr $self->{_str} => $self->{_start};
$getname = extract_delimited($string);
$self->{_posn} += length $getname;
return substr $getname => 1, length($getname) - 2; # strip the quotes
}
else {
my $string = substr $self->{_str} => $self->{_start};
($getname) = $string =~ /^($ATOM)/;
$self->{_posn} += length $getname;
return $getname;
}
}
# recognize a number
# XXX same issues as getname
sub getnum {
my $self = shift;
$self->{_start} = $self->{_posn};
my $string = substr $self->{_str} => $self->{_start};
my ($getnum) = $string =~ /^($RE{num}{real})/;
if ( '.' eq substr $getnum => -1, 1 ) {
$getnum = substr $getnum => 0, length($getnum) - 1;
}
$self->{_posn} += length $getnum;
return $getnum;
}
# get the term corresponding to a name.
# if the name is new, create a new variable
sub getvar {
my $self = shift;
my $string = $self->getname;
my $term = $self->{_vardict}{$string};
unless ($term) {
$term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum?
$self->{_vardict}{$string} = $term;
}
return ( $term, $string );
}
my $ANON = 'a';
sub get_anon {
my $self = shift;
# HACK!!!
my $string = '___' . $ANON++;
$self->advance;
my $term = $self->{_vardict}{$string};
unless ($term) {
$term = Term->new( $self->{_varnum}++ ); # XXX wrong _varnum?
$self->{_vardict}{$string} = $term;
}
return ( $term, $string );
}
# handle errors in one place
sub parseerror {
my ( $self, $character ) = @_;
my $linenum = $self->linenum;
croak "Unexpected character: ($character) at line number $linenum";
}
# skips whitespace and prolog comments
sub skipspace {
my $self = shift;
$self->advance while $self->current =~ /[[:space:]]/;
_skipcomment($self);
}
# XXX Other subtle differences
sub _skipcomment {
my $self = shift;
if ( $self->current eq '%' ) {
while ( $self->current ne "\n" && $self->current ne "#" ) {
$self->advance;
}
$self->skipspace;
}
if ( $self->current eq "/" ) {
$self->advance;
if ( $self->current ne "*" ) {
lib/AI/Prolog/Parser.pm view on Meta::CPAN
$self->advance;
if ( $self->current ne "/" ) {
$self->parseerror("Expecting terminating '/' on comment");
}
$self->advance;
$self->skipspace;
}
}
# reset the variable dictionary
sub nextclause {
my $self = shift;
$self->{_vardict} = {};
$self->{_varnum} = 0;
}
# takes a hash and extends it with the clauses in the string
# $program is a string representing a prolog program
# $db is an initial program that will be augmented with the
# clauses parsed.
# class method, not an instance method
sub consult {
my ( $class, $program, $db ) = @_;
$db ||= KnowledgeBase->new;
my $self = $class->new($program);
$self->linenum(1);
$self->skipspace;
until ( $self->empty ) {
my $termlist = $self->_termlist;
my $head = $termlist->term;
lib/AI/Prolog/Parser.pm view on Meta::CPAN
my $clause = Clause->new( $head, $body );
my $adding_builtins = Engine->_adding_builtins;
$clause->is_builtin(1) if $adding_builtins;
$db->$add( $clause, $adding_builtins );
$self->skipspace;
$self->nextclause; # new set of vars
}
return $db;
}
sub resolve {
my ( $class, $db ) = @_;
foreach my $termlist ( values %{ $db->ht } ) {
$termlist->resolve($db);
}
}
sub _termlist {
my ($self) = @_;
my $termlist = TermList->new;
my @ts = $self->_term;
$self->skipspace;
if ( $self->current eq ':' ) {
$self->advance;
if ( $self->current eq '=' ) {
lib/AI/Prolog/Parser.pm view on Meta::CPAN
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;
lib/AI/Prolog/Parser/PreProcessor.pm view on Meta::CPAN
package AI::Prolog::Parser::PreProcessor;
$REVISION = '$Id: PreProcessor.pm,v 1.2 2005/08/06 23:28:40 ovid Exp $';
$VERSION = '0.01';
use strict;
use warnings;
use aliased 'AI::Prolog::Parser::PreProcessor::Math';
sub process {
my ($class, $prolog) = @_;
# why the abstraction? Because I want DCGs in here, too. Maybe
# other stuff ...
$prolog = Math->process($prolog);
return $prolog;
}
1;
__END__
lib/AI/Prolog/Parser/PreProcessor/Math.pm view on Meta::CPAN
** pow
< lt
<= le
> gt
>= ge
== eq
\= ne
}
);
sub process {
my ( $class, $prolog ) = @_;
while ( $prolog =~ $expression ) {
my ( $old_expression, $lhs, $comp, $rhs ) = ( $1, $2, $3, $4 );
my $new_rhs = $class->_parse( $class->_lex($rhs) );
my $new_expression = sprintf
"%s(%s, %s)" => $convert{$comp},
$lhs, $new_rhs;
$prolog =~ s/\Q$old_expression\E/$new_expression/g;
}
return $prolog;
}
sub _lex {
my ( $class, $rhs ) = @_;
my $lexer = _lexer($rhs);
my @tokens;
while ( my $token = $lexer->() ) {
push @tokens => $token;
}
return \@tokens;
}
sub _lexer {
my $rhs = shift;
# the entire "$prev_op" thing is to allow the lexer to be aware of '7 + -3'
# $op_ok is false on the first pass because it can never be first, but we
# might have '-7 * (-2 + 3)'
my $op_ok = 0;
return sub {
LEXER: {
$op_ok = 0, return [ 'OP', $1 ]
if $op_ok && $rhs =~ /\G ($op) /gcx;
$op_ok = 1, return [ 'ATOM', $1 ]
if $rhs =~ /\G ($simple_math_term) /gcx;
$op_ok = 0, return [ 'LPAREN', '(' ]
if $rhs =~ /\G $lparen /gcx;
$op_ok = 1, return [ 'RPAREN', ')' ]
if $rhs =~ /\G $rparen /gcx;
redo LEXER if $rhs =~ /\G \s+ /gcx;
}
};
}
sub _parse {
my ( $class, $tokens ) = @_;
my $parens_left = 1;
REDUCE: while ($parens_left) {
my ( $first, $last );
for my $i ( 0 .. $#$tokens ) {
my $token = $tokens->[$i];
next unless $token;
if ( "(" eq _as_string($token) ) {
$first = $i;
}
lib/AI/Prolog/Parser/PreProcessor/Math.pm view on Meta::CPAN
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 ) = @_;
foreach my $op_re ( qr{(?:\*\*|[*/])}, qr{[+-]}, qr/\%/ ) {
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},
lib/AI/Prolog/Parser/PreProcessor/Math.pm view on Meta::CPAN
undef $tokens->[$next];
}
}
@$tokens = grep $_ => @$tokens;
}
#main::diag Dumper $tokens;
return $tokens->[0]; # should never have more than on token left
}
sub _prev_token {
my ( $tokens, $index ) = @_;
for my $i ( reverse 0 .. $index - 1 ) {
return $i if defined $tokens->[$i];
}
}
sub _next_token {
my ( $tokens, $index ) = @_;
for my $i ( $index + 1 .. $#$tokens ) {
return $i if defined $tokens->[$i];
}
}
sub _as_string { ref $_[0] ? $_[0][1] : $_[0] }
sub match { shift; shift =~ $expression }
# The following are testing hooks
sub _compare { shift; shift =~ /^$compare$/ }
sub _op { shift; shift =~ /^$op$/ }
sub _simple_rhs { shift; shift =~ /^$simple_rhs$/ }
sub _simple_group_term { shift; shift =~ /^$simple_group_term$/ }
sub _simple_math_term { shift; shift =~ /^$simple_math_term$/ }
sub _math_term { shift; shift =~ /^$math_term$/ }
sub _complex_rhs { shift; shift =~ /^$complex_rhs$/ }
sub _complex_group_term { shift; shift =~ /^$complex_group_term$/ }
1;
__END__
=head1 NAME
AI::Prolog::Parser::PreProcessor::Math - The AI::Prolog math macro
=head1 SYNOPSIS
lib/AI/Prolog/Term.pm view on Meta::CPAN
# 3. References (bound to another variable)
my $VARNUM = 1;
# controls where occurcheck is used in unification.
# In early Java versions, the occurcheck was always performed
# which resulted in lower performance.
my $OCCURCHECK = 0;
sub occurcheck {
my ( $class, $value ) = @_;
$OCCURCHECK = $value if defined $value;
return $OCCURCHECK;
}
# controls printing of lists as [a,b]
# instead of cons(a, cons(b, null))
sub prettyprint {1}
my $CUT = Cut->new(0);
sub CUT {$CUT}
sub new {
my $proto = shift;
my $class = CORE::ref $proto || $proto; # yes, I know what I'm doing
return $class->_new_var unless @_;
if ( 2 == @_ ) { # more common (performance)
return _new_from_functor_and_arity( $class, @_ )
unless 'ARRAY' eq CORE::ref $_[1];
}
elsif ( 1 == @_ ) {
my $arg = shift;
return _new_with_id( $class, $arg )
if !CORE::ref $arg && $arg =~ /^[[:digit:]]+$/;
return _new_from_string( $class, $arg ) if !CORE::ref $arg;
#return $arg->_term($class) if CORE::ref $arg && $arg->isa(Parser);
}
croak("Unknown arguments to Term->new");
}
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,
lib/AI/Prolog/Term.pm view on Meta::CPAN
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,
lib/AI/Prolog/Term.pm view on Meta::CPAN
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 => [],
lib/AI/Prolog/Term.pm view on Meta::CPAN
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} }
sub args { shift->{args} }
sub varid { shift->{varid} }
sub ref { shift->{ref} }
sub predicate { sprintf "%s/%d" => $_[0]->getfunctor, $_[0]->getarity }
sub deref {
my $self = shift;
while ( $self->{bound} && $self->{deref} ) {
$self = $self->{ref};
}
return $self;
}
sub bound {
my $self = shift;
while ( $self->{bound} && $self->{deref} ) {
$self = $self->{ref};
}
return $self->{bound};
}
sub is_bound { shift->bound }
sub traceln {
my ( $self, $msg ) = @_;
if ( $self->{trace} ) {
print "$msg\n";
}
}
sub dup {
my $self = shift;
$self->new( $self->{functor}, $self->{arity} );
}
# bind a variable to a term
sub bind {
my ( $self, $term ) = @_;
return if $self eq $term;
unless ( $self->{bound} ) {
$self->{bound} = 1;
$self->{deref} = 1;
$self->{ref} = $term;
}
else {
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 {
my ( $self, $pos, $val ) = @_;
if ( $self->{bound} && !$self->{deref} ) {
$self->{args}[$pos] = $val;
}
else {
croak( "AI::Prolog::Term->setarg($pos, "
. $val->to_string
. "). Cannot setarg on variables!" );
}
}
# retrieves an argument of a term
sub getarg {
my ( $self, $pos ) = @_;
# should check if position is valid
if ( $self->{bound} ) {
return $self->{ref}->getarg($pos) if $self->{deref};
return $self->{args}[$pos];
}
else {
croak("AI::Prolog::Term->getarg. Error -- lookup on unbound term!");
}
}
sub getfunctor {
my $self = shift;
return "" unless $self->{bound};
return $self->{ref}->getfunctor if $self->{deref};
return $self->{functor};
}
sub getarity {
my $self = shift;
return 0 unless $self->{bound};
return $self->{ref}->getarity if $self->{deref};
return $self->{arity};
}
# check whether a variable occurs in a term
# XXX Since a variable is not consideref to occur in itself,
# XXX added occurs1 and a new front end called occurs()
sub occurs {
my ( $self, $var ) = @_;
return if $self->{varid} == $var;
return $self->occurs1($var);
}
sub occurs1 {
my ( $self, $var ) = @_;
if ( $self->{bound} ) {
return $self->ref->occurs1($var) if $self->{deref};
for my $i ( 0 .. $self->arity - 1 ) {
return 1 if $self->{args}[$i]->occurs1($var);
}
}
else {
return $self->varid == $var;
}
}
# used internally for debugging
sub _dumpit {
local $^W;
my $self = shift;
my $indent = shift || '';
print( $indent . "source: ", $self->{source} );
print( $indent . "bound: ", ( $self->{bound} ? 'true' : 'false' ) );
print( $indent . "functor: ", ( $self->{functor} || 'null' ) );
if ( !$self->{ref} ) {
print( $indent . "ref: null" );
}
else {
lib/AI/Prolog/Term.pm view on Meta::CPAN
#print($indent . "args: ", scalar @{$self->{args}}) if defined $self->{args}[0];
print( $indent . "deref: ", ( $self->{deref} ? 'true' : 'false' ) );
print( $indent . "varid: ", $self->{varid}, "\n" );
}
# Unification is the basic primitive operation in logic programming.
# $stack: the stack is used to store the address of variables which
# are bound by the unification. This is needed when backtracking.
sub unify {
my ( $self, $term, $stack ) = @_;
#_dumpit($self);
#_dumpit($term);
foreach ( $self, $term ) {
$_ = $_->{ref} while $_->{bound} and $_->{deref};
}
if ( $self->{bound} and $term->{bound} ) { # bound and not deref
lib/AI/Prolog/Term.pm view on Meta::CPAN
$self->bind($term);
push @{$stack} => $self; # save for backtracking
return 1;
}
# refresh creates new variables. If the variables already exist
# in its arguments then they are used. This is used when parsing
# a clause so that variables throughout the clause are shared.
# Includes a copy operation.
sub refresh {
my ( $self, $term_aref ) = @_;
if ( $self->{bound} ) {
if ( $self->{deref} ) {
return $self->{ref}->refresh($term_aref);
}
else {
if ( 0 == $self->{arity} ) {
return $self;
}
else {
lib/AI/Prolog/Term.pm view on Meta::CPAN
}
}
# else unbound
unless ( $term_aref->[ $self->{varid} ] ) {
$term_aref->[ $self->{varid} ] = $self->new;
}
return $term_aref->[ $self->{varid} ];
}
sub to_data {
my $self = shift;
$self->{_results} = {};
# @results is the full results, if we ever need it
my @results = $self->_to_data($self);
return AsObject->new( $self->{_results} ), \@results;
}
sub _to_data {
my ( $self, $parent ) = @_;
if ( defined $self->{varname} ) {
# XXX here's where the [HEAD|TAIL] bug is. The engine works fine,
# but we can't bind TAIL to a result object and are forced to
# switch to raw_results.
my $varname = delete $self->{varname};
( $parent->{_results}{$varname} ) = $self->_to_data($parent);
$self->{varname} = $varname;
}
lib/AI/Prolog/Term.pm view on Meta::CPAN
}
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(@_);
}
sub _to_string {
my ( $self, $extended ) = @_;
if ( $self->{bound} ) {
my $functor = $self->functor;
my $arity = $self->arity;
my $prettyprint = $self->prettyprint;
return $self->ref->_to_string($extended) if $self->{deref};
return "[]" if NULL eq $functor && !$arity && $prettyprint;
my $string;
if ( "cons" eq $functor && 2 == $arity && $prettyprint ) {
$string = "[" . $self->{args}[0]->_to_string;
lib/AI/Prolog/Term.pm view on Meta::CPAN
# ----------------------------------------------------------
# Copy a term to put in the database
# - with new variables (freshly renumbered)
# ----------------------------------------------------------
# XXX XProlog
my %CVDICT;
my $CVN;
sub clean_up {
my $self = shift;
%CVDICT = ();
$CVN = 0;
return $self->_clean_up;
}
sub _clean_up {
my $self = shift;
my $term;
if ( $self->{bound} ) {
if ( $self->{deref} ) {
return $self->{ref}->_clean_up;
}
elsif ( defined $self->{arity} && 0 == $self->{arity} ) {
return $self;
}
else {
lib/AI/Prolog/Term.pm view on Meta::CPAN
$term = $CVDICT{$self};
unless ($term) {
$term = $self->new( $CVN++ );
$CVDICT{$self} = $term; # XXX Should this be $self->to_string?
}
}
return $term;
}
# From XProlog
sub value {
# int i, res = 0;
my $self = shift;
my ( $i, $res ) = ( 0, 0 );
unless ( $self->{bound} ) {
my $term = $self->to_string;
croak("Tried to to get value of unbound term ($term)");
}
return $self->{ref}->value if $self->{deref};
lib/AI/Prolog/Term/Cut.pm view on Meta::CPAN
package AI::Prolog::Term::Cut;
$REVISION = '$Id: Cut.pm,v 1.2 2005/02/20 18:27:55 ovid Exp $';
$VERSION = '0.1';
@ISA = 'AI::Prolog::Term';
use strict;
use warnings;
use aliased 'AI::Prolog::Term';
sub new {
my ($proto, $stack_top) = @_;
my $self = $proto->SUPER::new('!',0);
$self->{varid} = $stack_top;
return $self;
}
sub to_string {
my $self = shift;
return "Cut->$self->{varid}";
}
sub dup { # XXX recast as Term?
my $self = shift;
return $self->new($self->{varid});
}
1;
__END__
=head1 NAME
lib/AI/Prolog/Term/Number.pm view on Meta::CPAN
package AI::Prolog::Term::Number;
$REVISION = '$Id: Number.pm,v 1.3 2005/02/28 02:32:11 ovid Exp $';
$VERSION = '0.1';
@ISA = 'AI::Prolog::Term';
use strict;
use warnings;
use Scalar::Util qw/looks_like_number/;
use aliased 'AI::Prolog::Term';
sub new {
my ($proto, $number) = @_;
my $self = $proto->SUPER::new($number, 0);
$self->{varid} = defined $number && looks_like_number($number)
? $number
: 0;
return $self;
}
sub value { shift->{varid} }
sub dup { # should this be recast as the parent?
my $self = shift;
return $self->new($self->{varid});
}
1;
__END__
=head1 NAME
lib/AI/Prolog/TermList.pm view on Meta::CPAN
use Carp qw( croak confess );
use Hash::Util 'lock_keys';
use aliased 'AI::Prolog::Term';
use aliased 'AI::Prolog::Term::Number';
use aliased 'AI::Prolog::Parser';
use aliased 'AI::Prolog::TermList::Clause';
use aliased 'AI::Prolog::TermList::Primitive';
sub new {
#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 {
lib/AI/Prolog/TermList.pm view on Meta::CPAN
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;
}
sub _new_from_term_and_next {
my ( $class, $term, $next ) = @_;
my $self = $class->_new_from_term($term);
$self->{next} = $next;
return $self;
}
sub term { shift->{term} }
sub next {
my $self = shift;
if (@_) {
$self->{next} = shift;
return $self;
}
return $self->{next};
}
sub next_clause {
my $self = shift;
if (@_) {
# XXX debug
my $next_clause = shift;
no warnings 'uninitialized';
if ( $next_clause eq $self ) {
confess("Trying to assign a termlist as its own successor");
}
$self->{next_clause} = $next_clause;
return $self;
}
return $self->{next_clause};
}
sub to_string {
my $self = shift;
my $indent = "\n\t";
my $to_string = $indent . $self->term->to_string;
#my $to_string = "[" . $self->term->to_string;
my $tl = $self->next;
while ($tl) {
$to_string .= ",$indent" . $tl->term->to_string;
$tl = $tl->next;
}
return $to_string;
}
sub resolve { # a.k.a. lookup_in
my ( $self, $kb ) = @_;
my $predicate = $self->{term}->predicate;
$self->next_clause( $kb->get($predicate) );
}
1;
__END__
=head1 NAME
lib/AI/Prolog/TermList/Clause.pm view on Meta::CPAN
package AI::Prolog::TermList::Clause;
$REVISION = '$Id: Clause.pm,v 1.4 2005/08/06 23:28:40 ovid Exp $';
$VERSION = '0.1';
use strict;
use warnings;
use base 'AI::Prolog::TermList';
sub new {
# Term TermList
my $class = shift;
return $class->SUPER::new(@_);
}
sub to_string {
my $self = shift;
my ( $term, $next ) = ( $self->term, $self->next );
foreach ( $term, $next ) {
$_ = $_ ? $_->to_string : "null";
}
return sprintf "%s :- %s" => $term, $next;
}
sub is_builtin {
my $self = shift;
if (@_) {
$self->{is_builtin} = shift;
return $self;
}
return $self->{is_builtin};
}
1;
lib/AI/Prolog/TermList/Primitive.pm view on Meta::CPAN
package AI::Prolog::TermList::Primitive;
$REVISION = '$Id: Primitive.pm,v 1.2 2005/02/20 18:27:55 ovid Exp $';
$VERSION = '0.1';
@ISA = 'AI::Prolog::TermList';
use strict;
use warnings;
use Scalar::Util qw/looks_like_number/;
sub new {
my ($class, $number) = @_;
my $self = $class->SUPER::new; # correct?
$self->{ID} = looks_like_number($number) ? $number : 0;
return $self;
}
sub ID { shift->{ID} }
sub to_string { " <".shift->{ID}."> " }
1;
__END__
=head1 NAME
AI::Prolog::TermList::Primitive - Perl implementation of Prolog primitives.
=head1 SYNOPSIS
lib/AI/Prolog/TermList/Step.pm view on Meta::CPAN
package AI::Prolog::TermList::Step;
$REVISION = '$Id: Step.pm,v 1.2 2005/02/20 18:27:55 ovid Exp $';
$VERSION = '0.1';
@ISA = 'AI::Prolog::TermList';
use strict;
use warnings;
use aliased 'AI::Prolog::Term';
sub new {
my ($class, $termlist) = @_;
my $self = $class->SUPER::new;
$self->{next} = $termlist->next;
$termlist->{next} = $self;
$self->{term} = Term->new('STEP',0);
return $self;
}
1;
t/05examples.t view on Meta::CPAN
$prolog->query("append(X,Y,[a,b,c,d]).");
AI::Prolog::Engine->formatted(1);
is $prolog->results, 'append([], [a,b,c,d], [a,b,c,d])', 'Running the prolog should work';
is $prolog->results, 'append([a], [b,c,d], [a,b,c,d])', '... as should fetching more results';
is $prolog->results, 'append([a,b], [c,d], [a,b,c,d])', '... as should fetching more results';
is $prolog->results, 'append([a,b,c], [d], [a,b,c,d])', '... as should fetching more results';
is $prolog->results, 'append([a,b,c,d], [], [a,b,c,d])', '... as should fetching more results';
ok ! $prolog->results, '... and we should return false when we have no more results';
sub append_prog {
"append([], X, X)."
."append([W|X],Y,[W|Z]) :- append(X,Y,Z).";
}
t/10choicepoint.t view on Meta::CPAN
{
chdir 't' if -d 't';
unshift @INC => '../lib';
$CLASS = 'AI::Prolog::ChoicePoint';
use_ok($CLASS) or die;
}
my $to_string_called = 0;
{
package Goal;
sub new { bless {}=> shift }
sub to_string { $to_string_called++; "some goal" }
package Clause;
sub new { bless {}=> shift }
sub to_string { $to_string_called++; "some clause" }
}
can_ok $CLASS, 'new';
ok my $cpoint = $CLASS->new(Goal->new, Clause->new), '... and calling it should succeed';
isa_ok $cpoint, $CLASS, '... and the object it returns';
can_ok $cpoint, 'goal';
isa_ok $cpoint->goal, 'Goal', '... and the object it returns';
can_ok $cpoint, 'clause';
#!/usr/bin/perl
# '$Id: 25cut.t,v 1.1 2005/02/20 18:27:55 ovid Exp $';
use warnings;
use strict;
use Test::More tests => 27;
#use Test::More 'no_plan';
#XXX This is a bit annoying. Term knows about its subclass, CUT,
# and this forces us to use Term before we use_ok($CLASS).
use aliased 'AI::Prolog::Term';
my $CLASS;
BEGIN
{
chdir 't' if -d 't';
unshift @INC => '../lib';
$CLASS = 'AI::Prolog::Term::Cut';
use_ok($CLASS) or die;
}
t/25number.t view on Meta::CPAN
#!/usr/bin/perl
# '$Id: 25number.t,v 1.1 2005/02/20 18:27:55 ovid Exp $';
use warnings;
use strict;
use Test::More tests => 34;
#use Test::More 'no_plan';
#XXX This is a bit annoying. Term knows about its subclass, CUT,
# and this forces us to use Term before we use_ok($CLASS).
use aliased 'AI::Prolog::Term';
my $CLASS;
BEGIN
{
chdir 't' if -d 't';
unshift @INC => '../lib';
$CLASS = 'AI::Prolog::Term::Number';
use_ok($CLASS) or die;
}
t/40parser.t view on Meta::CPAN
can_ok $parser, 'empty';
ok ! $parser->empty, '... and it should return false if there is more stuff to parse';
$parser->advance; # skip ')'
$parser->advance; # skip '.'
$parser->skipspace;
ok $parser->empty, '... and return true when there is nothing left to parse. How sad.';
can_ok $parser, 'resolve';
my $termlist = Test::MockModule->new(TermList);
my $resolve = 0;
$termlist->mock('resolve', sub {$resolve++});
my $new_db = KnowledgeBase->new;
%{$new_db->ht} = map { $_ => TermList->new } 1 .. 3;
$parser->resolve($new_db);
is $resolve, 3, '... and TermList->resolve should be called once for each termlist in the db';
can_ok $CLASS, 'consult';
my $db = $CLASS->consult(<<'END_PROLOG');
owns(merlyn, gold).
owns(ovid, rubies).
END_PROLOG
t/50engine.t view on Meta::CPAN
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'
( run in 1.244 second using v1.01-cache-2.11-cpan-88abd93f124 )