AI-Prolog
view release on metacpan or search on metacpan
bin/aiprolog view on Meta::CPAN
#!/usr/local/bin/perl
eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
if 0; # not running under some shell
use warnings;
use strict;
use Term::ReadLine;
use Term::ReadKey;
use Pod::Usage 1.12;
use aliased 'AI::Prolog';
AI::Prolog::Engine->formatted(1);
# '$Id: aiprolog,v 1.7 2005/08/06 23:28:40 ovid Exp $';
bin/aiprolog view on Meta::CPAN
}
elsif ($query =~ /${COMMAND}more/i) {
$MORE = 1;
}
elsif ($query =~ /${COMMAND}no\s*more/i) {
$MORE = 0;
}
next;
}
eval {$prolog->query($query)};
if ($@) {
warn $@;
next;
}
$RESULTS = 1;
show_results($prolog);
while ($MORE && user_wants_more()) {
show_results($prolog);
}
}
lib/AI/Prolog/Cookbook.pod view on Meta::CPAN
Usage: C<member(Index, Item, List).>
member(1, SearchFor, [SearchFor|_]).
member(Index, SearchFor, [_|Tail]) :-
member(Previous, SearchFor, Tail),
Index is Previous + 1.
Please note that assignment in Prolog is via the C<is/2> infix operator. The
above code will fail if you use C<=/2>. This is a common source of bugs for
programmers new to Prolog. The C<=/2> predicate will unify the right hand side
with the left hand side. It will I<not> evaluate the left hand side. Thus:
X = 3 + Y.
% X is now plus(3,Y) (the internal form of the +/2 infix operator.)
If you prefer your list indices start with zero, alter the first clause as
follows:
member(0, SearchFor, [SearchFor|_]).
=head2 Gather elements from a list by indices.
lib/AI/Prolog/Engine.pm view on Meta::CPAN
_trace => 0, # whether or not tracing is done
_halt => 0, # will stop the aiprolog shell
_perlpackage => undef,
_step_flag => undef,
} => $class;
lock_keys %$self;
# to add a new primitive, use the binding operator (:=) to assign a unique
# index to the primitive and add the corresponding definition to
# @PRIMITIVES.
eval {
$self->_adding_builtins(1);
$self->{_db} = Parser->consult( <<' END_PROG', $prog );
ne(X, Y) :- not(eq(X,Y)).
if(X,Y,Z) :- once(wprologtest(X,R)) , wprologcase(R,Y,Z).
wprologtest(X,yes) :- call(X). wprologtest(X,no).
wprologcase(yes,X,Y) :- call(X).
wprologcase(no,X,Y) :- call(Y).
not(X) :- if(X,fail,true).
or(X,Y) :- call(X).
or(X,Y) :- call(Y).
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
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::
lib/AI/Prolog/Engine/Primitives.pm view on Meta::CPAN
}
if ( not defined $function_ref ) {
return FAIL;
}
# XXX What do to with the first arg?
my ( undef, $results_ref ) = $term->getarg(1)->to_data;
my @results = @{ $results_ref->[0] };
eval {
no strict 'refs'; ## no critic NoStrict
$function_ref->(@results);
};
if ( my $e = $@ ) {
# Extreme caution here.
if ( $e =~ UNDEFINED_SUBROUTINE_ERROR ) {
return FAIL;
}
#!/usr/bin/perl -w
use strict;
use Test::More;
eval "use Test::Pod 1.06";
plan skip_all => "Test::Pod 1.06 required for testing POD" if $@;
all_pod_files_ok();
# chicken and egg problem to squashing bugs.
use aliased 'AI::Prolog::Parser';
can_ok $CLASS, 'occurcheck';
is $CLASS->occurcheck, 0, '... and it should return a false value';
$CLASS->occurcheck(1);
is $CLASS->occurcheck, 1, '... but we should be able to set it to a true value';
can_ok $CLASS, 'new';
eval { $CLASS->new(1,2,3,4) };
ok $@, 'Calling new with arguments it does not expect should croak()';
like $@, qr/Unknown arguments to Term->new/,
'... with an appropriate error message';
# new, unbound term
ok my $term = $CLASS->new, 'Calling it without arguments should succeed';
isa_ok $term, $CLASS, '... and the object it returns';
#diag $term->to_string;
t/40parser.t view on Meta::CPAN
#!/usr/bin/perl
# '$Id: 40parser.t,v 1.6 2005/08/06 23:28:40 ovid Exp $';
use warnings;
use strict;
use Test::More;
BEGIN {
eval 'use Test::MockModule';
if ($@) {
plan skip_all => 'Test::MockModule required for this';
} else {
plan tests => 76;
}
}
#use Test::More 'no_plan';
my $CLASS;
BEGIN
t/40parser.t view on Meta::CPAN
is $parser->_start, 0, '... and it will not change the starting position';
is $parser->_posn, 3, '... or the current position';
$parser = $CLASS->new(' /* comment */ p(x)');
$parser->skipspace;
is $parser->current, 'p',
'skipspace() should ignore multiline comments';
is $parser->_start, 0, '... and it will not change the starting position';
is $parser->_posn, 16, '... but the position will indicate the new position';
eval {$CLASS->new('/* this is an unterminated comment')->skipspace};
ok $@, 'skipspace() should die if it encounters a comment with no end';
like $@, qr{Expecting terminating '/' on comment},
'... with an appropriate error message';
eval {$CLASS->new('/ * this is an unterminated comment')->skipspace};
ok $@, 'skipspace() should die if it encounters a poorly formed comment';
like $@, qr{Expecting '\*' after '/'},
'... with an appropriate error message';
$parser = $CLASS->new(<<'END_PROLOG');
% this is a comment
flies(pig, 789).
END_PROLOG
$parser->skipspace;
is $parser->current, 'f',
t/70builtins.t view on Meta::CPAN
#!/usr/bin/perl
# '$Id: 70builtins.t,v 1.7 2005/08/06 23:28:40 ovid Exp $';
use warnings;
use strict;
use Test::More;
BEGIN {
eval q{
use Test::MockModule;
use Test::Differences};
if ($@) {
plan skip_all => "Test::MockModule, Test::Differences required for this";
} else {
plan tests => 39;
}
}
#use Test::More qw/no_plan/;
use Clone qw/clone/;
t/70builtins.t view on Meta::CPAN
$prolog->query('append(X,Y,[a,b,c,d])');
is $prolog->results, 'append([], [a,b,c,d], [a,b,c,d])',
'... and it should return the correct results';
ok ! $prolog->results, '... and halt backtracking appropriately';
$prolog = Prolog->new(<<'END_PROLOG');
test_var(VAR,X) :-
if(var(VAR), eq(X,is_var), eq(X,not_var)).
END_PROLOG
$prolog->query('test_var(X, Y)');
is $prolog->results, 'test_var(A, is_var)', 'var(X) should evaluate to true';
$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';
$prolog->query('is(X,-7)');
is $prolog->results, 'is(-7, -7)', '... and it should handle negative numbers';
$prolog->query('is(X,.7)');
is $prolog->results, 'is(.7, .7)', '... and number which begin with decimal points';
$prolog->query('is(X,-.7)');
is $prolog->results, 'is(-.7, -.7)', '... and negative numbers with decimal points';
$prolog->query('is(7,X)');
eval {$prolog->results};
like $@, qr/Tried to to get value of unbound term \(A\)/,
'... but trying to call is(7,X) with an unbound rhs should die';
$prolog->query('is(7,7)');
is $prolog->results, 'is(7, 7)', '... but it should succeed if both terms are bound and equal';
$prolog->query('is(5,7)');
ok ! defined $prolog->results, '... and it should fail if both terms are bound but unequal';
$prolog->query('gt(4,3)');
t/99regression.t view on Meta::CPAN
#!/usr/bin/perl
# '$Id: 99regression.t,v 1.4 2005/08/06 23:28:40 ovid Exp $';
use warnings;
use strict;
use Test::More;
BEGIN {
eval q{use Test::MockModule};
if ($@) {
plan skip_all => "Test::MockModule, Test::Exception required for this";
} else {
plan tests => 5;
}
}
#use Test::More qw/no_plan/;
BEGIN
{
( run in 1.823 second using v1.01-cache-2.11-cpan-98e64b0badf )