view release on metacpan or  search on metacpan

lib/AI/Pathfinding/SMAstar/Path.pm  view on Meta::CPAN

#
#

package AI::Pathfinding::SMAstar::Path;

use strict;

BEGIN {
    use Exporter ();
    @Path::ISA         = qw(Exporter);
    @Path::EXPORT      = qw();
    @Path::EXPORT_OK   = qw($d);

  }

use vars qw($d $max_forgotten_nodes);  # used to debug destroy method for accounting purposes
$d = 0;
$max_forgotten_nodes = 0;


##################################################
# Path constructor 
##################################################
sub new {
    my $invocant = shift;
    my $class   = ref($invocant) || $invocant;
    my $self = {
	
	_state                    => undef,  # node in the search space
	_eval_func               => undef,
	_goal_p_func             => undef,
	_num_successors_func     => undef,
	_successors_iterator     => undef,
	_get_data_func           => undef,

	###########################################
	#
	#   path stuff
	#
	###########################################	
	_antecedent              => undef,  # pointer to the antecedent of this obj
	_f_cost                  => undef,  # g + h where g = cost so far, h = estimated cost to goal.

	_forgotten_node_fcosts   => [],     # array to store fcosts of forgotten nodes
	_forgotten_nodes_num     => 0,

	_forgotten_nodes_offsets => {},

	_depth                   => 0,     # depth used for memory-bounded search
	_descendants_produced    => [],
	_descendant_index        => undef,	
	_descendant_fcosts       => [],
	_descendants_on_queue    => 0,

	_descendands_deleted     => 0,
	_is_completed            => 0,
	_num_successors          => undef,
	_num_successors_in_mem   => 0,
	_is_on_queue             => 0,
	_iterator_index          => 0,      # to remember index of iterator for descendants
	_need_fcost_change       => 0,      # boolean

	@_,    # attribute override
    };

    return bless $self, $class;
        
}

##############################################
# accessors
##############################################

sub state{
    my $self = shift;
    if (@_) { $self->{_state} = shift }
    return $self->{_state};
}

sub antecedent{
    my $self = shift;
    if (@_) { $self->{_antecedent} = shift }
    return $self->{_antecedent};
}

sub f_cost{
    my $self = shift;
    if (@_) { $self->{_f_cost} = shift }
    return  $self->{_f_cost};
}

sub depth{
    my $self = shift;
    if (@_) { $self->{_depth} = shift }
    return  $self->{_depth};
}

sub is_completed{
    my $self = shift;
    if (@_) { $self->{_is_completed} = shift }
    return  $self->{_is_completed};
}

sub is_on_queue{
    my $self = shift;
    if (@_) { $self->{_is_on_queue} = shift }
    return  $self->{_is_on_queue};
}

sub descendants_deleted{
    my $self = shift;
    if (@_) { $self->{_descendants_deleted} = shift }
    return  $self->{_descendants_deleted};
}

sub need_fval_change{
    my $self = shift;
    if (@_) { $self->{_need_fcost_change} = shift }
    return  $self->{_need_fcost_change};
}




# new version 8
sub remember_forgotten_nodes_fcost
{
    my ($self, $node) = @_;      

    my $fcost = $node->{_f_cost};
    my $index = $node->{_descendant_index};

    $self->{_forgotten_node_fcosts}->[$index] = $fcost;
    
    return;
}






#----------------------------------------------------------------------------
# evaluation function f(n) = g(n) + h(n) where 
#
# g(n) = cost of path through this node
# h(n) = distance from this node to goal (optimistic)
#
# used for A* search.
#
sub fcost
{    
    my ($self) = @_;
    
    my $fcost = $self->{_f_cost};
    if(defined($fcost)){	    
	return $fcost;
    }

    my $eval_func = $self->{_eval_func};
    my $result =  $eval_func->($self->{_state});
    $self->{_f_cost} = $result;

    return $result;
}





sub is_goal
{
    my ($self) = @_;
      
    my $goal_p_func = $self->{_goal_p_func};
    my $result =  $goal_p_func->($self->{_state});

    return $result;
}



sub get_num_successors
{
    my ($self) = @_;
      
    my $num_successors_func = $self->{_num_successors_func};
    my $result =  $num_successors_func->($self->{_state});

    return $result;    
}


sub get_successors_iterator
{
    my ($self) = @_;
      
    my $successors_iterator = $self->{_successors_iterator};

    my $iterator = $successors_iterator->($self->{_state});
    
    return $iterator;    
}


    
    

#-----------------------------------------------------------------------------------------------
#
# Check whether we need to backup the fvals for a node when it is completed (recursive)
# Sets flags throughout path object's lineage, indicating whether fvals need to be updated.
#
#-----------------------------------------------------------------------------------------------
sub check_need_fval_change
{
    my ($self, $descendant_fcost, $descendant_ind) = @_;
 

    my $descendant_index = $self->{_descendant_index};

    if(!$self->is_completed()){
        # node not completed. no need to update fcost.
	$self->need_fval_change(0);
	return;
    }

    my $fcost = $self->{_f_cost};
    my $least_fcost2 = 99;
       
    
    my $min = sub {	
	my ($n1, $n2) = @_;
	return ($n1 < $n2 ? $n1 : $n2);
    };

    if($self->{_forgotten_nodes_num} != 0){ 
	foreach my $ind (keys %{$self->{_forgotten_nodes_offsets}}){	  
	    my $cost = $self->{_forgotten_node_fcosts}->[$ind];	    
	    if($cost != -1 && $cost < $least_fcost2){
		$least_fcost2 = $cost;
	    }		    
	}
    }    
   
    my $j = 0;
    foreach my $fc (@{$self->{_descendant_fcosts}}){
	if(defined($descendant_ind) && $j != $descendant_ind){
	    if($fc != -1 && $fc < $least_fcost2){
		$least_fcost2 = $fc;
	    }
	}
	else{
	    # special case for index $j:  it is the caller's index.
	    if(defined($descendant_fcost)){	
		if($descendant_fcost < $least_fcost2) {
		    $least_fcost2 = $descendant_fcost;
		}
	    }
	    elsif($fc != -1 && $fc < $least_fcost2){
		$least_fcost2 = $fc;
	    }
	}	
	$j++;	
    }
    
    # if no successors, this node cannot lead to 
    # goal, so set fcost to infinity.
    if($self->{_num_successors} == 0){ 
	$least_fcost2 = 99;
    }
  
    if($least_fcost2 != $fcost){		
        # setting need_fcost_change to 1
	$self->need_fval_change(1);
	my $antecedent = $self->{_antecedent};
	
	# recurse on the antecedent
	if($antecedent){
	    $antecedent->check_need_fval_change($least_fcost2, $descendant_index);
	}	
    }
}





#-----------------------------------------------------------------------------------------------
#
# Backup the fvals for a node when it is completed.
#
#-----------------------------------------------------------------------------------------------
sub backup_fvals
{
    my ($self) = @_;
    
    while($self){
	
	if(!$self->is_completed()){
            # node not completed, return
	    return;
	}
	
	my $fcost = $self->{_f_cost};
	my $least_fcost = 99;

	my $min = sub {	
	    my ($n1, $n2) = @_;
	    return ($n1 < $n2 ? $n1 : $n2);
	};
	
	if($self->{_forgotten_nodes_num} != 0){ 
	    foreach my $ind (keys %{$self->{_forgotten_nodes_offsets}}){	  
		my $cost = $self->{_forgotten_node_fcosts}->[$ind];	    
		if($cost != -1 && $cost < $least_fcost){
		    $least_fcost = $cost;
		}		    
	    }
	}    

	foreach my $fc (@{$self->{_descendant_fcosts}}){
	    if($fc != -1 && $fc < $least_fcost){
		$least_fcost = $fc;
	    }
	}

	# if no successors, this node cannot lead to 
	# goal, so set fcost to infinity.
	if($self->{_num_successors} == 0){ 
	    $least_fcost = 99;
	}
	
	if($least_fcost != $fcost){		
        # changing fcost from $self->{_f_cost} to $least_fcost	    
	    $self->{_f_cost} = $least_fcost;
	    
	    my $antecedent = $self->{_antecedent};
	    if($antecedent){
		my $descendant_index = $self->{_descendant_index};