view release on metacpan or  search on metacpan

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

sub elements { [ values %{ shift->{ht} } ] }

sub reset {
    my $self = shift;
    $self->{ht}         = {};
    $self->{primitives} = {};
    $self->{oldIndex}   = '';
}

sub consult {
    my ( $self, $program ) = @_;
    $self->{oldIndex} = '';
    return Parser->consult( $program, $self );
}

sub add_primitive {
    my ( $self, $clause ) = @_;
    my $term      = $clause->term;
    my $predicate = $term->predicate;
    my $c         = $self->{ht}{$predicate};
    if ($c) {
        while ( $c->next_clause ) {
            $c = $c->next_clause;
        }
        $c->next_clause($clause);
    }
    else {
        $self->{primitives}{$predicate} = 1;
        $self->{ht}{$predicate}         = $clause;
    }
}

sub add_clause {
    my ( $self, $clause ) = @_;
    my $term      = $clause->term;
    my $predicate = $term->predicate;
    if ( $self->{primitives}{$predicate} ) {
        carp("Trying to modify primitive predicate: $predicate");
        return;
    }
    unless ( $predicate eq $self->{oldIndex} ) {
        delete $self->{ht}{$predicate};
        $self->{ht}{$predicate} = $clause;
        $self->{oldIndex} = $predicate;
    }
    else {
        my $c = $self->{ht}{$predicate};
        while ( $c->next_clause ) {
            $c = $c->next_clause;
        }
        $c->next_clause($clause);
    }
}

sub assert {
    my ( $self, $term ) = @_;
    $term = $term->clean_up;

    # XXX whoops.  Need to check exact semantics in Term
    my $newC = Clause->new( $term->deref, undef );

    my $predicate = $term->predicate;
    if ( $self->{primitives}{$predicate} ) {
        carp("Trying to assert a primitive: $predicate");
        return;
    }
    my $c = $self->{ht}{$predicate};
    if ($c) {
        while ( $c->next_clause ) {
            $c = $c->next_clause;
        }
        $c->next_clause($newC);
    }
    else {
        $self->{ht}{$predicate} = $newC;
    }
}

sub asserta {
    my ( $self, $term ) = @_;
    my $predicate = $term->predicate;
    if ( $self->{primitives}{$predicate} ) {
        carp("Trying to assert a primitive: $predicate");
        return;
    }
    $term = $term->clean_up;
    my $newC = Clause->new( $term->deref, undef );
    my $c = $self->{ht}{$predicate};
    $newC->next_clause($c);
    $self->{ht}{$predicate} = $newC;
}

sub retract {
    my ( $self, $term, $stack ) = @_;
    my $newC = Clause->new( $term, undef );    #, undef);
    my $predicate = $term->predicate;
    if ( exists $self->{primitives}{$predicate} ) {
        carp("Trying to retract a primitive: $predicate");
        return;
    }
    my $cc;
    my $c = $self->{ht}{$predicate};

    while ($c) {
        my $vars = [];
        my $xxx  = $c->term->refresh($vars);
        my $top  = @{$stack};

        if ( $xxx->unify( $term, $stack ) ) {
            if ($cc) {
                $cc->next_clause( $c->next_clause );
            }
            elsif ( !$c->next_clause ) {
                delete $self->{ht}{$predicate};
            }
            else {
                $self->{ht}{$predicate} = $c->next_clause;
            }
            return 1;
        }
        for ( my $i = @{$stack} - $top; $i > 0; $i-- ) {
            my $t = pop @{$stack};
            $t->unbind;
        }
        $cc = $c;
        $c  = $c->next_clause;
    }
    return;
}

sub retractall {
    my ( $self, $term, $arity ) = @_;
    my $predicate = $term->predicate;
    if ( $self->{primitives}{$predicate} ) {
        carp("Trying to retractall primitives: $predicate");
        return;
    }
    delete $self->{ht}{$predicate};
    return 1;
}

sub get {
    my ( $self, $term ) = @_;
    my $key = ref $term ? $term->to_string : $term;
    return $self->{ht}{$key};
}

sub set {
    my ( $self, $term, $value ) = @_;
    my $key = ref $term ? $term->to_string : $term;
    $self->{ht}{$key} = $value->clean_up;
}

sub _print { print @_ }