AI::Perlog(2) unification proposition

[arhuman]

No sir, AI::Perlog isn't in limbo ;-)

I've been playing with it lately (not as much as I wanted though )
and it still makes me dream...

Your code seems to assume that the positions do matter with the predicates
args, while your explanation seems to suggest the contrary
(Your funny relation with whiskey ;-)

I don't recall how it was in Prolog,
but I think that some predicates should be order dependant :

        father('arhuman','disciple')

should only be read "arhuman is disciple's father"
it's definitly not the same as

        father('disciple','arhuman')

whereas some predicates obviously shouldn't

        color('red','green')

could be also written

        color('green','red')

It's probably not that important, but if AI::Perlog will have to handle
both cases it may be a good idea to take it into account now.

Anyway, to contribute I've coded AI::Perlog2.
Don't be scare it's NOT a fork, takeover attempt or whatever,
it's only my way to try to play with concepts and
to experiment without messing too much with your code :-)
Take it only as an implementation playground (and maybe a test/bench helper)
to experiment/choose data structures.

While poorly coded AI::Perlog2 might even includes some ideas
which could be put into your module :

• There's a rudimentary unification algorithm which (seems to) work(s).
  
• I've tried to use simpler structures (that I could understand ;-)
  
• It handles also "order independent" predicates
  (when first argument is a '?')
  
• Included a dirty 'load_from_file' method
  which would allow to load facts easily regardless of the implementation
  (that's why I ruled serialization out))
  to enable use of both Perlog and Perlog2 on the same facts database...
  

UPDATE : display function slightly edited.

It's a quick rewrites of a now defunct (due to a stupid file overwrite) "cleaner" version
based on your code, so it's full of bugs, not consistent with lot of features missing...
I submit it to benefits from the monastery's experience
and be corrected on some problems/flaws already encountered
(that might even finally make me understand why you choose that 'monster structure' for your module ;-)

*******************************************************

package AI::Perlog2;
use strict;
use Carp;
#use Devel::StealthDebug;

our $order_do_matter = 1;

sub new {
        my $class = shift;
        my $self  = {
                _predicates    => {},
        };
        bless $self, $class;
}

sub add_fact {
        my ($self,$predicate,@args) = @_;
        my $predicate_id;
        
        if ( exists $self->{_predicates}{ $predicate } ) {
                $predicate_id = $self->{_predicates}{$predicate}{id};
        } else {
                $self->{_predicates}{$predicate}{id}=$predicate_id 
                        = $self->{_next_vertex}++;

                {       

                        no strict 'refs';
                        my $package = ref $self;
                        *{"$package::$predicate"} = 
                        sub {
                                my $self = shift;
                                unshift @_ => $predicate;
                                $self->_predicate( @_ );
                        };
                }
        }

        $self->{_collection}{$predicate_id}{join '+',sort @args} = \@a
+rgs;
        
        return 1;
}
sub _predicate {
        my $self      = shift;
        my $predicate = shift;
        my @args      = @_;

        my %result;

        if ( $args[0] eq '?') {         # Ugly way to handle 
                shift @args;                    # position independant
+ predicate
                $order_do_matter = 0;   #
        }

        carp "Predicate $predicate not found in database" 
                if ! exists $self->{_predicates}{ $predicate };
        
        my $key = join '+',sort @args;

        my $predicate_id = $self->{_predicates}{$predicate}{id};

        if ($self->{_collection}{$predicate_id}{$key}) {
                return ( "$predicate($key)"=> ["ok"] )                
+          # Match 
!
        } elsif ( grep {/^\$.+$/} @args ) {  
                #
                # Instead using all the predicates relating to the id
                #  (whe could use piped grep with the given args on th
+e
                #  keys %{$self->{_collection}{$predicate_id}} to rest
+rict
                #  to a small set of data to process and speed up thin
+gs...)
                #

        
                # There's some var in the args
                # Let's try unification 
               if ($order_do_matter) {
                        for my $key (keys %{$self->{_collection}{$pred
+icate_id}}) {
                                my @stored = @{$self->{_collection}{$p
+redicate_id}{$key}
};
                                my %tempresults;
                                my $ko = 0;
                                for my $i (0..$#stored) {
                                        next    if (($args[$i] eq '_')
+ or ($args[$i] eq 
$stored[$i]));
                                        if ($args[$i] =~ /^\$.+$/) {
                                                $tempresults{$args[$i]
+} = $stored[$i];
                                        } else { 
                                                $ko = 1;
                                        }
                                }
                                for my $tempkey (keys %tempresults) {
                                        push @{$result{$tempkey}}, $te
+mpresults{$tempkey
}       unless $ko;
                                }
                        }
                        return %result;
                } else {
                        for my $key (keys %{$self->{_collection}{$pred
+icate_id}}) {
                                my @stored = @{$self->{_collection}{$p
+redicate_id}{$key}
};
                                my %stored;
                                
                                for my $item (@stored) {
                                        $stored{$item} = 1;
                                }
                                
                                my (%tempresults, $ko, %args);
                        
                                for my $i (grep {!/^\$.+$/} @args) {
                                        next if $i eq '_';
                                        if ($stored{$i}) {
                                                delete $stored{$i};
                                                next;
                                        } else { 
                                                %stored = ();
                                                last;
                                        }
                                }
                        
                                my $set = join'+', grep {/^\$.+$/} @ar
+gs;
                                if (%stored) {
                                        push @{$result{$set}}, join'+'
+, keys %stored;   
                                }
                        }
                }

                return %result;
        } else {        
                return undef;                                         
+  # No match
        }
}


#
# "implementation independant" fact loader
#
sub load_from_file {
        my $self = shift;
        my $file = shift;
        open INFILE,"<$file"    or die "Can't open $file ($!)";
        while (my $method = <INFILE>) {
                chomp $method;
                eval "\$self->$method";
                die "Load error : $@ line $. ($method)"  if $@;
        }
        close INFILE;
}

sub display {
        if (!$#_) {         
            print "       No match\n";
            return;
        }

        my %x = @_;

        my @var = keys %x;
        my $first = shift @var;
        my $pos;

        for my $sol (@{$x{$first}}) {
                print "       possible  $first = ",$sol;
                for my $var (@var) {
                        print " , $var = ", ${$x{$var}}[$pos];
                }
                print $/;
                $pos++;
        }
}

1;

*************************************************