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/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/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/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
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
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;
lib/AI/Prolog/Parser.pm view on Meta::CPAN
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';
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/70builtins.t view on Meta::CPAN
'if(X,Y,Z) should call Y if X is satisfied';
ok ! $prolog->results, '... and it should only provide correct results';
$prolog->query("steals(ovid,X).");
is $prolog->results, 'steals(ovid, nothing)',
'... and it should call Z if X cannot be satisfied';
ok ! $prolog->results, '... and it should only provide correct results';
my $faux_engine = Test::MockModule->new(Engine);
my @stdout;
$faux_engine->mock(_print => sub { push @stdout => @_ });
$prolog->query("nl.");
$prolog->results;
is_deeply \@stdout, ["\n"], "nl should print a newline";
$prolog->query("not(thief(ovid)).");
is $prolog->results, 'not(thief(ovid))',
'not() should succeed if query cannot be proven';
$prolog->query("not(thief(badguy)).");
t/70builtins.t view on Meta::CPAN
$prolog->query('loves(sally,X)');
is $prolog->results, 'loves(sally, A)',
'... and the asserted fact should remain unchanged.';
$prolog->do("retract(loves(ovid,perl)).");
$prolog->query("loves(ovid,X)");
ok ! $prolog->results,
"retract(X) should remove a fact from the database";
my @test_me;
sub test_me {
my ( $first, $second, $third, $fourth ) = @_;
@test_me = ( "\L$first", "\U$second", "\u$third", $fourth );
return;
}
$prolog->query(q{perlcall2( "test_me", ["FIND ME","and me","also me", 42] ).});
ok $prolog->results, 'Called a perl function ok';
is_deeply \@test_me, ["find me","AND ME", "Also me", 42],
'Perl function got results ok';
@test_me = ();
t/70builtins.t view on Meta::CPAN
$prolog->query('test_var(42, Y)');
is $prolog->results, 'test_var(42, not_var)',
'... and var(42) should evaluate to not true';
$prolog->query('test_var(ovid, Y)');
is $prolog->results, 'test_var(ovid, not_var)',
'... and var(ovid) should evaluate to not true';
{
my $faux_kb = Test::MockModule->new(KnowledgeBase);
my @stdout;
$faux_kb->mock(_print => sub { push @stdout => @_ });
$prolog->query('listing.');
$prolog->results;
my $results = join ''=> @stdout;
my $count = ($results =~ s/(\d+\.\s+\w+\/\d+:)//g);
ok $count, 'listing should display a listing of the database';
}
t/99regression.t view on Meta::CPAN
[ 'a', 'c' ],
[ 'b', 'a' ],
[ 'b', 'c' ],
[ '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 0.656 second using v1.01-cache-2.11-cpan-a5abf4f5562 )