view release on metacpan or  search on metacpan

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

package AI::Prolog::Term;
$REVISION = '$Id: Term.pm,v 1.10 2005/08/06 23:28:40 ovid Exp $';

$VERSION = '0.07';
use strict;
use warnings;
use Carp qw( croak confess );

use Hash::Util 'lock_keys';

use aliased 'AI::Prolog::Term::Cut';
use aliased 'AI::Prolog::Parser';

use aliased 'Hash::AsObject';

use constant NULL => 'null';

# Var is a type of term
# A term is a basic data structure in Prolog
# There are three types of terms:
#   1. Values     (i.e., have a functor and arguments)
#   2. Variables  (i.e., unbound)
#   3. References (bound to another variable)

my $VARNUM = 1;

# controls where occurcheck is used in unification.
# In early Java versions, the occurcheck was always performed
# which resulted in lower performance.

my $OCCURCHECK = 0;

sub occurcheck {
    my ( $class, $value ) = @_;
    $OCCURCHECK = $value if defined $value;
    return $OCCURCHECK;
}

# controls printing of lists as [a,b]
# instead of cons(a, cons(b, null))

sub prettyprint {1}

my $CUT = Cut->new(0);
sub CUT {$CUT}

sub new {
    my $proto = shift;
    my $class = CORE::ref $proto || $proto;    # yes, I know what I'm doing
    return $class->_new_var unless @_;
    if ( 2 == @_ ) {    # more common (performance)
        return _new_from_functor_and_arity( $class, @_ )
            unless 'ARRAY' eq CORE::ref $_[1];
    }
    elsif ( 1 == @_ ) {
        my $arg = shift;
        return _new_with_id( $class, $arg )
            if !CORE::ref $arg && $arg =~ /^[[:digit:]]+$/;
        return _new_from_string( $class, $arg ) if !CORE::ref $arg;

#return $arg->_term($class)            if   CORE::ref $arg && $arg->isa(Parser);
    }
    croak("Unknown arguments to Term->new");
}

sub _new_from_string {
    my ( $class, $string ) = @_;
    my $parsed = Parser->new($string)->_term($class);
}

sub _new_var {
    my $class = shift;

    #print "*** _new_var @{[$VARNUM+1]}";
    my $self = bless {
        functor => undef,
        arity   => 0,
        args    => [],

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

        }
        else {
            return;    # functor/arity don't match ...
        }
    }    # at least one arg not bound ...
    if ( $self->{bound} ) {

        # added missing occurcheck
        if ( $self->occurcheck ) {
            if ( $self->occurs( $term->varid ) ) {
                return;
            }
        }
        $term->bind($self);
        push @{$stack} => $term;    # side-effect -- setting stack vars
        return 1;
    }

    # do occurcheck if turned on
    return if $self->occurcheck && $term->occurs( $self->varid );
    $self->bind($term);
    push @{$stack} => $self;        # save for backtracking
    return 1;
}

# refresh creates new variables.  If the variables already exist
# in its arguments then they are used.  This is used when parsing
# a clause so that variables throughout the clause are shared.
# Includes a copy operation.

sub refresh {
    my ( $self, $term_aref ) = @_;
    if ( $self->{bound} ) {
        if ( $self->{deref} ) {
            return $self->{ref}->refresh($term_aref);
        }
        else {
            if ( 0 == $self->{arity} ) {
                return $self;
            }
            else {
                my $term = ( CORE::ref $self)
                    ->_new_from_functor_and_arity( $self->{functor},
                    $self->{arity} );
                for my $i ( 0 .. $self->{arity} - 1 ) {
                    $term->{args}[$i]
                        = $self->{args}[$i]->refresh($term_aref);
                }
                return $term;
            }
        }
    }

    # else unbound
    unless ( $term_aref->[ $self->{varid} ] ) {
        $term_aref->[ $self->{varid} ] = $self->new;
    }
    return $term_aref->[ $self->{varid} ];
}

sub to_data {
    my $self = shift;
    $self->{_results} = {};

    # @results is the full results, if we ever need it
    my @results = $self->_to_data($self);
    return AsObject->new( $self->{_results} ), \@results;
}

sub _to_data {
    my ( $self, $parent ) = @_;
    if ( defined $self->{varname} ) {

        # XXX here's where the [HEAD|TAIL] bug is.  The engine works fine,
        # but we can't bind TAIL to a result object and are forced to
        # switch to raw_results.
        my $varname = delete $self->{varname};
        ( $parent->{_results}{$varname} ) = $self->_to_data($parent);
        $self->{varname} = $varname;
    }
    if ( $self->{bound} ) {
        my $functor = $self->functor;
        my $arity   = $self->arity;
        return $self->ref->_to_data($parent) if $self->{deref};
        return [] if NULL eq $functor && !$arity;
        if ( "cons" eq $functor && 2 == $arity ) {
            my @result = $self->{args}[0]->_to_data($parent);
            my $term   = $self->{args}[1];

            while ( "cons" eq $term->getfunctor && 2 == $term->getarity ) {
                if ( $term->{varname} ) {
                  push @result => $term->_to_data($parent);
                } else {
                  push @result => $term->getarg(0)->_to_data($parent);
                }
                $term = $term->getarg(1);
            }

            # XXX Not really sure about this one
            push @result => $term->_to_data($parent)
                unless NULL eq $term->getfunctor && !$term->getarity;

            #    ? "]"
            #    : "|" . $term->_to_data($parent) . "]";
            return \@result;
        }
        else {
            my @results = $self->functor;
            if ( $self->arity ) {

                #push @results => [];
                my $arity = $self->arity;
                my @args  = @{ $self->args };
                if (@args) {
                    for my $i ( 0 .. $arity - 1 ) {
                        push @results => $args[$i]->_to_data($parent);
                    }

                    # I have no idea what the following line was doing.
                    #push @results => $args[$arity - 1]->_to_data($parent)
                }
            }
            return @results;
        }
    }    # else unbound;
    return undef;
}

my %varname_for;
my $varname = 'A';

sub to_string {
    require Data::Dumper;
    my $self = shift;
    return $self->_to_string(@_);
}

sub _to_string {
    my ( $self, $extended ) = @_;
    if ( $self->{bound} ) {
        my $functor     = $self->functor;
        my $arity       = $self->arity;
        my $prettyprint = $self->prettyprint;
        return $self->ref->_to_string($extended) if $self->{deref};
        return "[]" if NULL eq $functor && !$arity && $prettyprint;
        my $string;
        if ( "cons" eq $functor && 2 == $arity && $prettyprint ) {
            $string = "[" . $self->{args}[0]->_to_string;
            my $term = $self->{args}[1];

            while ( "cons" eq $term->getfunctor && 2 == $term->getarity ) {
                $string .= "," . $term->getarg(0)->_to_string;
                $term = $term->getarg(1);
            }

            $string .=
                ( NULL eq $term->getfunctor && !$term->getarity )
                ? "]"
                : "|" . $term->_to_string . "]";
            return "$string";
        }
        else {
            $string = $self->functor;
            if ( $self->arity ) {
                $string .= "(";
                if ( $self->arity ) {
                    local $Data::Dumper::Terse  = 1;    # don't use $var1
                    local $Data::Dumper::Indent = 0;    # no newline
                    my @args = map {
                        my $string = $_->_to_string;
                        $string =~ /\s/
                            && !$_->arity
                            ? Data::Dumper::Dumper($string)
                            : $string;
                    } @{ $self->args };
                    $string .= join ", " => @args;
                }
                $string .= ")";
            }
        }
        return $string;
    }    # else unbound;
         # return "_" . $self->varid;
    my $var = $self->{varname} || $varname_for{ $self->varid } || $varname++;
    $varname_for{ $self->varid } = $var;
    return $var;
}

# ----------------------------------------------------------
#  Copy a term to put in the database
#    - with new variables (freshly renumbered)
# ----------------------------------------------------------

# XXX XProlog
my %CVDICT;
my $CVN;

sub clean_up {
    my $self = shift;
    %CVDICT = ();
    $CVN    = 0;
    return $self->_clean_up;
}

sub _clean_up {
    my $self = shift;
    my $term;
    if ( $self->{bound} ) {
        if ( $self->{deref} ) {
            return $self->{ref}->_clean_up;
        }
        elsif ( defined $self->{arity} && 0 == $self->{arity} ) {
            return $self;
        }
        else {
            $term = $self->dup;
            for my $i ( 0 .. $self->{arity} - 1 ) {
                $term->{args}[$i] = $self->{args}[$i]->_clean_up;
            }
        }
    }
    else {    # unbound
        $term = $CVDICT{$self};
        unless ($term) {
            $term = $self->new( $CVN++ );
            $CVDICT{$self} = $term;    # XXX Should this be $self->to_string?
        }
    }
    return $term;
}

# From XProlog
sub value {

    # int i, res = 0;
    my $self = shift;
    my ( $i, $res ) = ( 0, 0 );

    unless ( $self->{bound} ) {
        my $term = $self->to_string;
        croak("Tried to to get value of unbound term ($term)");
    }
    return $self->{ref}->value if $self->{deref};
    my $functor = $self->getfunctor;
    my $arity   = $self->getarity;
    if ( 'rnd' eq $functor && 1 == $arity ) {

        # implement rand
    }
    if ( $arity < 2 ) {
        my $term = $self->to_string;
        croak("Term ($term) is not binary");
    }
    my $arg0 = $self->{args}[0]->value;
    my $arg1 = $self->{args}[1]->value;

    return $arg0 + $arg1 if 'plus'  eq $functor;
    return $arg0 - $arg1 if 'minus' eq $functor;
    return $arg0 * $arg1 if 'mult'  eq $functor;
    return $arg0 / $arg1 if 'div'   eq $functor;
    return $arg0 % $arg1 if 'mod'   eq $functor;
    return $arg0**$arg1  if 'pow'   eq $functor;
    croak("Unknown operator ($functor)");
}

1;

__END__

=head1 NAME

AI::Prolog::Term - Create Prolog Terms.

=head1 SYNOPSIS

 my $query = Term->new("steals(Somebody, Something).");

=head1 DESCRIPTION

See L<AI::Prolog|AI::Prolog> for more information.  If you must know more,
there are plenty of comments sprinkled through the code.

=head1 BUGS

A query using C<[HEAD|TAIL]> syntax does not bind properly with the C<TAIL>
variable when returning a result object.  This bug can be found in the
C<_to_data> method of this class.

=head1 SEE ALSO

W-Prolog:  L<http://goanna.cs.rmit.edu.au/~winikoff/wp/>

Michael BartE<225>k's online guide to programming Prolog:
L<http://kti.ms.mff.cuni.cz/~bartak/prolog/index.html>

=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