view release on metacpan or  search on metacpan

lib/AI/Pathfinding/AStar.pm  view on Meta::CPAN

package AI::Pathfinding::AStar;

use 5.006;
use strict;
use warnings;
use Carp;

our $VERSION = '0.10';

use Heap::Binomial;

use AI::Pathfinding::AStar::AStarNode;
my $nodes;

sub _init {
    my $self = shift;
    croak "no getSurrounding() method defined" unless $self->can("getSurrounding");

    return $self->SUPER::_init(@_);
}

sub doAStar
{
	my ($map, $target, $open, $nodes, $max) = @_;

	my $n = 0;
	FLOOP:	while ( (defined $open->top()) && ($open->top()->{id} ne $target) ) {

		#allow incremental calculation
		last FLOOP if (defined($max) and (++$n == $max));

		my $curr_node = $open->extract_top();
		$curr_node->{inopen} = 0;
		my $G = $curr_node->{g};

		#get surrounding squares
		my $surr_nodes = $map->getSurrounding($curr_node->{id}, $target);
		foreach my $node (@$surr_nodes) {
			my ($surr_id, $surr_cost, $surr_h) = @$node;

			#skip the node if it's in the CLOSED list
			next if ( (exists $nodes->{$surr_id}) && (! $nodes->{$surr_id}->{inopen}) );

			#add it if we haven't seen it before
			if (! exists $nodes->{$surr_id}) {
				my $surr_node = AI::Pathfinding::AStar::AStarNode->new($surr_id,$G+$surr_cost,$surr_h);
				$surr_node->{parent} = $curr_node;
				$surr_node->{cost}   = $surr_cost;
				$surr_node->{inopen} = 1;
				$nodes->{$surr_id}   = $surr_node;
				$open->add($surr_node);
			}
			else {
				#otherwise it's already in the OPEN list
				#check to see if it's cheaper to go through the current
				#square compared to the previous path
				my $surr_node = $nodes->{$surr_id};
				my $currG     = $surr_node->{g};
				my $possG     = $G + $surr_cost;
				if ($possG < $currG) {
					#change the parent
					$surr_node->{parent} = $curr_node;
					$surr_node->{g}      = $possG;
					$open->decrease_key($surr_node);
				}
			}
		}
	}
}

sub fillPath
{
	my ($map,$open,$nodes,$target) = @_;
	my $path = [];

        my $curr_node = (exists $nodes->{$target}) ? $nodes->{$target} : $open->top();
	while (defined $curr_node) {
		unshift @$path, $curr_node->{id};
		$curr_node = $curr_node->{parent};