package AI::Prolog::KnowledgeBase;
$REVISION = '$Id: KnowledgeBase.pm,v 1.5 2005/06/25 23:06:53 ovid Exp $';
$VERSION = '0.02';
use strict;
use warnings;

use aliased 'AI::Prolog::Engine';
use aliased 'AI::Prolog::Parser';
use aliased 'AI::Prolog::TermList::Clause';

sub new {
    bless {
        ht         => {},
        primitives => {}, # only uses keys
        oldIndex   => "",
    } => shift;
}

sub ht {shift->{ht}} # temp hack XXX

sub to_string {
    my $self = shift;
    return "{" .
        (join ', ' =>
            map  { join '=' => $_->[0], $_->[1] }
            sort { $a->[2] <=> $b->[2] }
            map  { [$_ , $self->_sortable_term($self->{_vardict}{$_}) ] }
                keys %{$self->{ht}})
        ."}";
}

sub _sortable_term {
    my ($self, $term) = @_;
    my $string = $term->to_string;
    my $number = substr $string => 1;
    return $string, $number;
}

sub put {
    my ($self, $key, $termlist) = @_;
    $self->{ht}{$key} = $termlist;
}

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}) {
        require Carp;
        Carp::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}) {
        require Carp && Carp::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}) {
        require Carp && Carp::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}) {
        require Carp && Carp::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}) {
        require Carp && Carp::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 @_}

sub dump {
    my ($self, $full) = @_;
    my $i = 1;
    while (my ($key, $value) = each %{$self->{ht}}) {
        next if ! $full && ($self->{primitives}{$key} || $value->is_builtin);
        if ($value->isa(Clause)) {
            _print($i++.". $key: \n");
            do {
                _print("   " . $value->term->to_string);
                if ($value->next) {
                    _print(" :- " . $value->next->to_string);
                }
                _print(".\n");
                $value = $value->next_clause;
            } while ($value);
        }
        else {
            _print($i++.". $key = $value\n");
        }
    }
    _print("\n");
}

sub list {
    my ($self, $predicate) = @_;
    print "\n$predicate: \n";
    my $head = $self->{ht}{$predicate} 
        or warn "Cannot list unknown predicate ($predicate)";
    while ($head) {
        print "   " . $head->term->to_string;
        if ($head->next) {
            print " :- " . $head->next->to_string;
        }
        print ".\n";
        $head = $head->next_clause;
    }
}

1;

__END__

=head1 NAME

AI::Prolog::KnowledgeBase - The Prolog database.

=head1 SYNOPSIS

 my $kb = KnowledgeBase->new;

=head1 DESCRIPTION

There are no user-serviceable parts inside here.  See L<AI::Prolog|AI::Prolog>
for more information.  If you must know more, there are a few comments
sprinkled through the code.

=head1 AUTHOR

Curtis "Ovid" Poe, E<lt>moc tod oohay ta eop_divo_sitrucE<gt>

Reverse the name to email me.

This work is based on W-Prolog, L<http://goanna.cs.rmit.edu.au/~winikoff/wp/>,
by Dr. Michael Winikoff.  Many thanks to Dr. Winikoff for granting me
permission to port this.

=head1 COPYRIGHT AND LICENSE

Copyright 2005 by Curtis "Ovid" Poe

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut