File Coverage

lib/AI/Prolog/Engine.pm

Criterion	Covered	Total	%
statement	155	186	83.3
branch	52	74	70.2
condition	8	12	66.6
subroutine	27	35	77.1
pod	6	10	60.0
total	248	317	78.2

package AI::Prolog::Engine;
$REVISION = '$Id: Engine.pm,v 1.13 2005/08/06 23:28:40 ovid Exp $';
$VERSION  = '0.4';
use strict;
use warnings;
use Carp qw( confess carp );

use Scalar::Util qw/looks_like_number/;
use Hash::Util 'lock_keys';

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::TermList::Primitive';
use aliased 'AI::Prolog::KnowledgeBase';
use aliased 'AI::Prolog::Parser';
use aliased 'AI::Prolog::ChoicePoint';

use AI::Prolog::Engine::Primitives;

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,
        _cp             => undef,
        _retract_clause => undef,
        _trace       => 0,       # whether or not tracing is done
        _halt        => 0,       # will stop the aiprolog shell
        _perlpackage => undef,
        _step_flag   => undef,
    } => $class;
    lock_keys %$self;

    # to add a new primitive, use the binding operator (:=) to assign a unique
    # index to the primitive and add the corresponding definition to
    # @PRIMITIVES.
    eval {
        $self->_adding_builtins(1);
        $self->{_db} = Parser->consult( <<'        END_PROG', $prog );
            ne(X, Y) :- not(eq(X,Y)).
            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).
            true.
            % the following are handled internally.  Don't use the
            % := operator.  Eventually, I'll make this a fatal error.
            % See AI::Prolog::Engine::Builtins to see the code for these
            !          :=  1.
            call(X)    :=  2.
            fail       :=  3.
            consult(X) :=  4.
            assert(X)  :=  5.
            retract(X) :=  7.
            retract(X) :- retract(X).
            listing    :=  8.
            listing(X) :=  9.
            print(X)   := 10.
            write(X)   := 10.
            println(X) := 11.
            writeln(X) := 11.
            nl         := 12.
            trace      := 13.
            notrace    := 13.
            is(X,Y)    := 15.
            gt(X,Y)    := 16.
            lt(X,Y)    := 17.
            ge(X,Y)    := 19.
            le(X,Y)    := 20.
            halt       := 22.
            var(X)     := 23.
            %seq(X)     := 30.
            help       := 31.
            help(X)    := 32.
            gensym(X)  := 33.
            perlcall2(X,Y) := 34.
            eq(X,X).
            not(X) :- X, !, fail.
            not(X).
            %if(X, Yes, _ ) :- seq(X), !, seq(Yes).
            %if(X, _  , No) :- seq(No).
            %if(X, Yes) :- seq(X), !, seq(Yes).
            %if(X, _  ).
            %or(X,Y) :- seq(X).
            %or(X,Y) :- seq(Y).
            once(X) :- X , !.
        END_PROG
        $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} );
            }
            $self->{_step_flag} = 1;
            $self->trace(1);
        }
        $self->dump_goal if $self->{_trace};
        $self->step      if $self->{_step_flag};

        unless ( $self->{_goal} ) {

            # we've succeeded.  return results
            if ( $self->formatted ) {
                return $self->_call->to_string;
            }
            else {
                my @results = $self->_call->to_data;
                return $self->raw_results
                    ? $results[1]
                    : $results[0];
            }
        }

        unless ( $self->{_goal} && $self->{_goal}{term} ) {
            croak("Engine->run fatal error.  goal->term is null!");
        }
        unless ( $self->{_goal}->{next_clause} ) {
            my $predicate = $self->{_goal}{term}->predicate;
            _warn("WARNING:  undefined predicate ($predicate)\n");
            next if $self->backtrack;    # if we backtracked, try again
            return;                      # otherwise, we failed
        }

        my $clause = $self->{_goal}->{next_clause};
        if ( my $next_clause = $clause->{next_clause} ) {
            push @{ $self->{_stack} } => $self->{_cp}
                = ChoicePoint->new( $self->{_goal}, $next_clause, );
        }
        my $vars      = [];
        my $curr_term = $clause->{term}->refresh($vars);
        if ( $curr_term->unify( $self->{_goal}->term, $self->{_stack} ) ) {
            $clause = $clause->{next};
            if ( $clause && $clause->isa(Primitive) ) {
                if (   !$self->do_primitive( $self->{_goal}->{term}, $clause )
                    && !$self->backtrack )
                {
                    return;
                }
            }
            elsif ( !$clause ) {    # matching against fact
                $self->{_goal} = $self->{_goal}->{next};
                if ( $self->{_goal} ) {
                    $self->{_goal}->resolve( $self->{_db} );
                }
            }
            else {                  # replace goal by clause body
                my ( $p, $p1, $ptail );    # termlists
                for ( my $i = 1; $clause; $i++ ) {

                    # will there only be one CUT?
                    if ( $clause->{term} eq Term->CUT ) {
                        $p = TermList->new( Cut->new($stackTop) );
                    }
                    else {
                        $p = TermList->new( $clause->{term}->refresh($vars) );
                    }

                    if ( $i == 1 ) {
                        $p1 = $ptail = $p;
                    }
                    else {
                        $ptail->next($p);
                        $ptail = $p;    # XXX ?
                    }
                    $clause = $clause->{next};
                }
                $ptail->next( $self->{_goal}->{next} );
                $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} );
    }
    return 1;
}

1;

__END__