Re: AI in Perl - proof of concept

[shotgunefx]

Here's a different take that I'm sure is has a couple gotchas. It's definitely rough around the edges but it's very flexible. Will need to add negations.

my $ p = AI::Thingy->new('shotgunefx',is=>[qw(person programmer)], knows=>['everything'],has=>[qw(angst coupe)] );
print $p, has($p,'valuable') ? " has " : "doesn't have ", "something valuable\n"; 

---

update
Fixed typo, added snippet.

#!/usr/bin/perl -w
use strict;

package AI::Thingy;
use overload        (
        '""'    => \&stringify,
);

my $THING_ID = 0;

use Data::Dumper;

our (%OBJS) = ();

%OBJS = ();
our $VERSION = '0.01';
our @EXPORT    = qw (is has assert);
our @EXPORT_OK = qw();
our @EXPORT_FAIL = qw();
########################################################
sub import {
    no strict 'refs';
    my $used_name = shift ; # Remove the Module name.

    my ($Version) = grep { m/^\d[\d.]*$/} @_;
    my @ex =  grep { !m/^(\d[\d\.]+)$/} @_;
    die "Insufficient or missing \$VERSION: $VERSION, $Version require
+d." if $Version  && $VERSION <= $Version;
    push @ex, @EXPORT ;
    my %EXP  = map {($_,'mKay')} @EXPORT,@EXPORT_OK;
    $EXP{$_} = 'Bad' for @EXPORT_FAIL;
    my $that_pack = caller();
    foreach (@ex){
        next if m/^\d[\d\.]+$/;
        die "Denied. Can't export $_" if defined $EXP{$_} && $EXP{$_} 
+eq 'Bad';
        unless (defined $EXP{$_} && $EXP{$_} eq 'mKay') {
            # Lets make some accessors...
            die "Can't export unknown symbol $_" if $_ =~/^[\@\$\*\%]/
+;
            my $att = $_;
            *{__PACKAGE__.'::'.$att} = *{$that_pack.'::'.$att} = sub {
my ($self,$what) = @_; 
    return defined $what ? $self->{$att}{$what} :  keys %{$self->{$att
+}};
};
        }
        m/^([\@\$\*\&\%]?)(\w+)/;
        my ($t,$v) = ($1,$2);
        $t = '&' unless $t;
        *{$that_pack.'::'.$v} = $t eq '@' && \@{$v} || $t eq '%' && \%
+{$v} || 
                    $t eq '&' && \&{$v} || $t eq '$' && \${$v} || 
                    $t eq '*' && \*{$v} || \*{$_};
    }

}

sub Objects {
    my ($Cl,$type) = @_;
    my @objs = map { $OBJS{$_}->{'__IDENTITY'} } sort keys %OBJS;
    return defined $type ? grep{ $OBJS{$_}->{is}{$type} } @objs : @obj
+s;

}
########################################################
sub new {
    my $class = shift;
    my $self  = { has=>{}, is=>{}   };
    my $name = shift;
    $self->{__THINGID} = $THING_ID++;
    $self->{NAME} = $name || $self->{__THINGID};
    bless($self, $class);
    $self->assert(@_);
    return $self;
} 
########################################################
sub has($$) {
    my $self = shift;
    my $what = shift;
    return sort keys %{$self->{has}} unless defined $what;
    return $self->{has}{$what} if exists $self->{has}{$what};
    # Else look for it.
    my %seen = ();
    _has(\%seen,$what, keys %{ $self->{has} } );
    

}

########################################################
sub _has{
    my ($seen,$target,@has) = @_;
    my $val;
    foreach my $h (@has){
        $seen->{$h} ? next : $seen->{$h}++;
        return $OBJS{$h}{is}->{$target} if exists $OBJS{$h}{is}->{$tar
+get};
        
        $val =  _is($seen,$target,keys     %{$OBJS{$h}->{is} }
        );
        last if $val;
    }
    return $val; 
}
########################################################
sub _is {
    my ($seen,$target,@is) = @_;
    foreach my $h (@is){
        $seen->{$h} ? next : $seen->{$h}++;
        return $OBJS{$h}{is}->{$target} if exists $OBJS{$h}{is}->{$tar
+get};
        _has($seen,$target,keys %{$OBJS{$h}->{__IDENTITY}->{has} });
    }
    return;


}
########################################################
sub is($$) {
    my $self = shift;
    my $what = shift;
    return $what ? $OBJS{$self}{is}->{$what} : sort keys %{$OBJS{$self
+}{is}};

}
########################################################
sub assert{
    my $self = shift;
    my %args = (
        has=> undef,
        is => undef,
        @_,
    );

    foreach my $prop (keys %args){
        if ($prop eq 'is'){
            $OBJS{$self}->{'__IDENTITY'} = $self;
            foreach my $k (@{$args{$prop}}){
                $OBJS{$self}->{is}{$k}++;
            }
        }else{
            foreach my $k (@{$args{$prop}}){
                $self->{$prop}{$k}++;
            }
        }
    }


}





sub stringify{
    my $self = shift;
    return $self->{NAME};
}




package main;


AI::Thingy->import qw(has is knows wants);     # Make these accessors
my %things = (
                    merlyn =>{
                        has=>[ 'gold' ],
                        is=>[ 'person', 'author'],
                        knows=>['perl', 'kudra'],
                        
                    },
                    shotgunefx=>{
                        has=>['nothing'],
                        is=>['person', 'depraved'],
                    },
                    ovid =>{
                        is=>[ 'person'],
                        has=>[ 'pocketLint', 'cheapWhiskey','diamonds'
+ ],
                        knows=>['kungfu', 'munitions'],
                    },
                    diamonds=>{
                        is=> ['gem'],
                    },
                    gem=>{
                        is=>['valuable'],
                    },
                    kungfu=>{
                        is=>['power', 'valuable'],
                    },
                    power=>{
                        is=>['valuable']
                    },
                    kudra =>{
                        is=>[ 'person'],
                        has=> [ 'dominationfund'],
                        knows=>['ovid'],
                        
                    },
                    gold=> {
                        is=>[ 'thing','currency'],
                    },
                    currency=>{
                        is=>['valuable'],
                    },
                    dominationfund=>{
                        is=>['thing'],
                    },
                    cheapWhiskey=>{
                        is=>['thing'],
                    },
                    pocketLint =>{
                        is=>['thing'],
                    },
                );

foreach my $p (keys %things){
    $things{$p} = AI::Thingy->new($p, %{$things{$p}} );
    
}

my @people = AI::Thingy->Objects('person');    # Retrieve all the peop
+le

# For is() && has() will try and do taxonomy. ovid has diamonds, diamo
+nds are gems, gems are valuable.

foreach my $person ( @people ){

    if ( has($person,'valuable') ){
        print "$person has valuables\n";
    }else{
        print "$person is a thief\n";
        # Rob anyone who is rich and we don't know.
        print     map {"\twill fleece $_\n"} 
                grep {"$_" ne "$person" && has($_,'valuable') && !know
+s($person,$_) } 
                @people

    }
}

-Lee

"To be civilized is to deny one's nature."