view release on metacpan or  search on metacpan

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

        #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
sub bind {
    my ( $self, $term ) = @_;
    return if $self eq $term;
    unless ( $self->{bound} ) {
        $self->{bound} = 1;
        $self->{deref} = 1;
        $self->{ref}   = $term;
    }
    else {
        croak(    "AI::Prolog::Term->bind("
                . $self->to_string
                . ").  Cannot bind to nonvar!" );
    }
}

# unbinds a term -- i.e., resets it to a variable
sub unbind {
    my $self = shift;
    $self->{bound} = 0;
    $self->{ref}   = undef;

    # XXX Now possible for a bind to have had no effect so ignore safety test
    # XXX if (bound) bound = false;
    # XXX else IO.error("Term.unbind","Can't unbind var!");
}

# set specific arguments.  A primitive way of constructing terms is to
# create them with Term(s,f) and then build up the arguments.  Using the
# parser is much simpler
sub setarg {
    my ( $self, $pos, $val ) = @_;
    if ( $self->{bound} && !$self->{deref} ) {
        $self->{args}[$pos] = $val;
    }
    else {
        croak(    "AI::Prolog::Term->setarg($pos, "
                . $val->to_string
                . ").  Cannot setarg on variables!" );
    }
}

# retrieves an argument of a term
sub getarg {
    my ( $self, $pos ) = @_;

    # should check if position is valid
    if ( $self->{bound} ) {
        return $self->{ref}->getarg($pos) if $self->{deref};
        return $self->{args}[$pos];
    }
    else {
        croak("AI::Prolog::Term->getarg.  Error -- lookup on unbound term!");
    }
}

sub getfunctor {
    my $self = shift;
    return "" unless $self->{bound};
    return $self->{ref}->getfunctor if $self->{deref};
    return $self->{functor};
}

sub getarity {
    my $self = shift;
    return 0 unless $self->{bound};
    return $self->{ref}->getarity if $self->{deref};
    return $self->{arity};
}

# check whether a variable occurs in a term
# XXX Since a variable is not consideref to occur in itself,
# XXX added occurs1 and a new front end called occurs()
sub occurs {
    my ( $self, $var ) = @_;
    return if $self->{varid} == $var;
    return $self->occurs1($var);
}

sub occurs1 {
    my ( $self, $var ) = @_;
    if ( $self->{bound} ) {
        return $self->ref->occurs1($var) if $self->{deref};
        for my $i ( 0 .. $self->arity - 1 ) {
            return 1 if $self->{args}[$i]->occurs1($var);
        }
    }
    else {
        return $self->varid == $var;
    }
}

# used internally for debugging
sub _dumpit {
    local $^W;
    my $self = shift;
    my $indent = shift || '';
    print( $indent . "source:  ", $self->{source} );
    print( $indent . "bound:  ", ( $self->{bound} ? 'true' : 'false' ) );

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

        print( $indent . "ref:  null" );
    }
    else {
        print( "\n$indent" . "ref:" );
        $self->{ref}->_dumpit( $indent . '  ' );
    }
    print( $indent . "arity:  ", $self->{arity} );
    if ( defined $self->{args}[0] ) {
        print( $indent. "args:" );
        foreach ( @{ $self->{args} } ) {
            $_->_dumpit( $indent . "  " );
        }
    }
    else {
        print( $indent. "args:  null" );
    }

#print($indent . "args:  ", scalar @{$self->{args}}) if defined $self->{args}[0];
    print( $indent . "deref:  ", ( $self->{deref} ? 'true' : 'false' ) );
    print( $indent . "varid:  ", $self->{varid}, "\n" );
}

# Unification is the basic primitive operation in logic programming.
# $stack: the stack is used to store the address of variables which
# are bound by the unification.  This is needed when backtracking.

sub unify {
    my ( $self, $term, $stack ) = @_;

    #_dumpit($self);
    #_dumpit($term);

    foreach ( $self, $term ) {
        $_ = $_->{ref} while $_->{bound} and $_->{deref};
    }

    if ( $self->{bound} and $term->{bound} ) {    # bound and not deref
        if (   $self->functor eq $term->getfunctor
            && $self->arity == $term->getarity )
        {
            for my $i ( 0 .. $self->arity - 1 ) {
                return
                    unless $self->{args}[$i]
                    ->unify( $term->getarg($i), $stack );
            }
            return 1;
        }
        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