view release on metacpan or  search on metacpan

lib/AI/Prolog/Engine.pm  view on Meta::CPAN

    }
    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: $@");

lib/AI/Prolog/Engine.pm  view on Meta::CPAN

        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__

=head1 NAME

AI::Prolog::Engine - Run queries against a Prolog database.

=head1 SYNOPSIS

 my $engine = AI::Prolog::Engine->new($query, $database).
 while (my $results = $engine->results) {
     print "$result\n";
 }

=head1 DESCRIPTION

C<AI::Prolog::Engine> is a Prolog engine implemented in Perl.

The C<new()> function actually bootstraps some Prolog code onto your program to
give you access to the built in predicates listed in the
L<AI::Prolog::Builtins|AI::Prolog::Builtins> documentation.