view release on metacpan or  search on metacpan

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

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    => [],

        # if bound is false, $self is a reference to a free variable
        bound => 0,
        varid => $VARNUM++,

        # if bound and deref are both true, $self is a reference to a ref
        deref => 0,
        ref   => undef,

        ID       => undef,
        varname  => undef,
        _results => undef,

        #source  => "_new_var",
    } => $class;
    lock_keys %$self;
    return $self;
}

sub _new_with_id {
    my ( $class, $id ) = @_;

    #print "*** _new_with_id: $id";
    my $self = bless {
        functor => undef,
        arity   => 0,
        args    => [],

        # if bound is false, $self is a reference to a free variable
        bound => 0,
        varid => $id,

        # if bound and deref are both true, $self is a reference to a ref
        deref => 0,
        ref   => undef,

        varname  => undef,
        ID       => undef,
        _results => undef,

        #source  => "_new_with_id: $id",
    } => $class;
    lock_keys %$self;
    return $self;
}

sub _new_from_functor_and_arity {
    my ( $class, $functor, $arity ) = @_;
    my $print_functor = defined $functor ? $functor : 'null';
    confess "undefined arity" unless defined $arity;

    #print "*** _new_from_functor_and_arity: ($print_functor) ($arity)";
    my $self = bless {
        functor => $functor,
        arity   => $arity,
        args    => [],

        # if bound is false, $self is a reference to a free variable
        bound => 1,
        varid => 0,    # XXX ??
             # if bound and deref are both true, $self is a reference to a ref
        deref => 0,
        ref   => undef,

        varname  => undef,
        ID       => undef,
        _results => undef,

        #source  => "_new_from_functor_and_arity: ($print_functor) ($arity)",
    } => $class;
    lock_keys %$self;
    return $self;
}

sub varnum  {$VARNUM}              # class method
sub functor { shift->{functor} }
sub arity   { shift->{arity} }
sub args    { shift->{args} }
sub varid   { shift->{varid} }
sub ref     { shift->{ref} }
sub predicate { sprintf "%s/%d" => $_[0]->getfunctor, $_[0]->getarity }

sub deref {
    my $self = shift;
    while ( $self->{bound} && $self->{deref} ) {
        $self = $self->{ref};
    }
    return $self;
}

sub bound {
    my $self = shift;
    while ( $self->{bound} && $self->{deref} ) {
        $self = $self->{ref};
    }
    return $self->{bound};
}

sub is_bound { shift->bound }

sub traceln {
    my ( $self, $msg ) = @_;
    if ( $self->{trace} ) {
        print "$msg\n";
    }
}

sub dup {
    my $self = shift;
    $self->new( $self->{functor}, $self->{arity} );
}

# bind a variable to a term