view release on metacpan or  search on metacpan

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

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;
}

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

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;
        }
    }