view release on metacpan or  search on metacpan

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

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} } ) );
        }
        else {
            $p = TermList->new($t2);
        }
        if ( $i++ == 0 ) {
            $p1 = $ptail = $p;
        }
        else {
            $ptail->next($p);
            $ptail = $p;
        }
        $term = $term->getarg(1);
    }
    $ptail->next( $self->{_goal}->next );
    $self->{_goal} = $p1;
    $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 $/;
            $prolog = <$fh>;
        }
        $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 ) = @_;