view release on metacpan or  search on metacpan

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

#
# PriorityQueue.pm
#

# Author:  matthias beebe
# Date :  June 2008
#
#
package AI::Pathfinding::SMAstar::PriorityQueue;


use Tree::AVL;
use AI::Pathfinding::SMAstar::Path;
use AI::Pathfinding::SMAstar::TreeOfQueues;
use Carp;
use strict;



##################################################
# PriorityQueue constructor 
##################################################
sub new {
    my $invocant = shift;
    my $class   = ref($invocant) || $invocant;
    my $self = { 
        _hash_of_trees_ref    => {},
	
	_cost_min_max_tree   => Tree::AVL->new( fcompare => \&fp_compare,  # floating-point compare
						fget_key => sub { $_[0] },
						fget_data => sub { $_[0] },),

	f_depth        => \&AI::Pathfinding::SMAstar::Path::depth,
	f_fcost        => \&AI::Pathfinding::SMAstar::Path::fcost,
	f_avl_compare  => \&AI::Pathfinding::SMAstar::Path::compare_by_depth,
	f_avl_get_key  => \&AI::Pathfinding::SMAstar::Path::depth,
	f_avl_get_data => \&AI::Pathfinding::SMAstar::Path::get_data,

	_size                 => 0,

	@_,    # attribute override
    };
    return bless $self, $class;
}

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

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

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



################################################
##
## other methods       
##
################################################

sub insert {
    my ($self, $pobj) = @_;

    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my $cost_hash_key_func = $self->{f_fcost};

    my $cost_min_max_tree = $self->{_cost_min_max_tree};

    my $depth_func = $self->{f_depth};
    
    my $avl_compare_func = $self->{f_avl_compare};
    my $avl_get_key_func = $self->{f_avl_get_key};
    my $avl_get_data_func = $self->{f_avl_get_data};

    my $cost_key = $pobj->$cost_hash_key_func();
    my $data = $pobj->$avl_get_data_func();

    
    # inserting pobj with key: $cost_key, data: $data    
    if(!$cost_hash_ref->{$cost_key}){
	# no tree for this depth yet, so create one.
	my $avltree = AI::Pathfinding::SMAstar::TreeOfQueues->new(
	    f_avl_compare => $avl_compare_func,
	    f_obj_get_key => $avl_get_key_func,
	    f_obj_get_data => $avl_get_data_func,
	    );
       
	$avltree->insert($pobj);	
	$cost_hash_ref->{$cost_key} = \$avltree;
	# insert the cost_key in the cost tree
	$cost_min_max_tree->insert($cost_key);
    }
    else{
    # there is already a tree at $cost_key, so inserting there	
	my $avltree = $cost_hash_ref->{$cost_key};
	$$avltree->insert($pobj);	
    }    
    $self->{_size} = $self->{_size} + 1;
    my $antecedent = $pobj->{_antecedent};
    if($antecedent){
	$antecedent->{_descendants_on_queue} = $antecedent->{_descendants_on_queue} + 1;
    }
    $pobj->is_on_queue(1);
}


sub print_trees_in_order
{
     my ($self) = @_;

     my $cost_hash_ref = $self->{_hash_of_trees_ref};
               
     for my $cost_key (keys %$cost_hash_ref){
	 if(!$cost_hash_ref->{$cost_key}){
	     # no tree for this depth.	     
	     #print "no tree at key $depth_key\n";
	 }
	 else{
	     #print "contents of tree with depth $depth_key\n";	     
	     my $avltree = $cost_hash_ref->{$cost_key};	     
	     $$avltree->print();
	 }	 
     }      
}


#-----------------------------------
# get_list
#
# return a list of all objects in queue
#
#-----------------------------------
sub get_list
{
     my ($self) = @_;

     my $cost_hash_ref = $self->{_hash_of_trees_ref};
          
     my @list;
     
     for my $cost_key (keys %$cost_hash_ref){
	 if($cost_hash_ref->{$cost_key}){
	     my $avltree = $cost_hash_ref->{$cost_key};	     
	     push(@list, $$avltree->get_list());
	 }	 
     }     
     return @list;
}


sub is_empty
{
    my ($self) = @_;
    
    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my @cost_keys = (keys %$cost_hash_ref);
    
    if(!@cost_keys){
	return 1;
    }
    else{
	return 0;
    }
}


sub remove
{
    my ($self, $obj, $cmp_func) = @_;

    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my @cost_keys = (keys %$cost_hash_ref);
    

    my $cost_min_max_tree = $self->{_cost_min_max_tree};
    
    
    my $avl_get_data_func = $self->{f_avl_get_data};
    my $cost_hash_key_func = $self->{f_fcost};
    my $depth_func = $self->{f_depth};
    

    my $cost_key = $obj->$cost_hash_key_func();
    my $data = $obj->$avl_get_data_func();
    
    if(!$cost_hash_ref->{$cost_key}){
	# no tree for this cost_key 	
	return;
    }
    else{
	# found the tree at $cost_key, trying to remove obj from there
	
	my $avltree = $cost_hash_ref->{$cost_key};
	$$avltree->remove($obj, $cmp_func);	

	# if tree is empty, remove it from hash
	if($$avltree->is_empty()){
	    delete $cost_hash_ref->{$cost_key}; 
	    $cost_min_max_tree->remove($cost_key);
	}	
	$self->{_size} = $self->{_size} - 1;
    }    
    my $antecedent = $obj->{_antecedent};
    if($antecedent){
	$antecedent->{_descendants_on_queue} = $antecedent->{_descendants_on_queue} - 1;
    }

    $obj->is_on_queue(0);
    return;
}

sub deepest_lowest_cost_leaf 
{
    my ($self) = @_;
   
    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my @cost_keys = (keys %$cost_hash_ref);

 
    my $cost_min_max_tree = $self->{_cost_min_max_tree};

    if(!@cost_keys){
	# queue is empty
	return;
    }

    # get the lowest cost from cost_keys  
    my $lowest_cost_key = $cost_min_max_tree->smallest();
    if(!$lowest_cost_key){
	croak "deepest_lowest_cost_leaf: object not found in min-max heap\n";	
    }    
 
    
    if(!$cost_hash_ref->{$lowest_cost_key}){
	# no tree for this cost.	     
	return;
    }
    else{
	my $avltree = $cost_hash_ref->{$lowest_cost_key};
	my $obj = $$avltree->pop_largest_oldest();  # get the deepest one
	my $antecedent = $obj->{_antecedent};
	
	# if tree is empty, remove it from hash and heap.
	if($$avltree->is_empty()){
	    #tree is empty, removing key $lowest_cost_key	    
	    delete $cost_hash_ref->{$lowest_cost_key}; 
	    $cost_min_max_tree->pop_smallest();
	}		

	if($antecedent){
	    $antecedent->{_descendants_on_queue} = $antecedent->{_descendants_on_queue} - 1;
	}
	
	$obj->is_on_queue(0);
	$self->{_size} = $self->{_size} - 1;
	return $obj;   
    }
}

sub deepest_lowest_cost_leaf_dont_remove
{
    my ($self) = @_;
    
    my $avl_compare_func = $self->{f_avl_compare};
    my $avl_get_key_func = $self->{f_avl_get_key};
    my $avl_get_data_func = $self->{f_avl_get_data};
    
    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my @cost_keys = (keys %$cost_hash_ref);



    my $cost_min_max_tree = $self->{_cost_min_max_tree};

    if(!@cost_keys){
	# queue is empty
	return;
    }

    # get the lowest cost from @cost_keys 
    my $lowest_cost_key = $cost_min_max_tree->smallest();
    if(!$lowest_cost_key){
	croak "deepest_lowest_cost_leaf_dont_remove: object not found in min-max heap\n";
    }
    
    # obtaining object from lowest-cost tree at cost:  $lowest_cost_key\n";
    if(!$cost_hash_ref->{$lowest_cost_key}){
	# no tree for this cost.	     
	return;
    }
    else{
	my $avltree = $cost_hash_ref->{$lowest_cost_key};
        # found tree at key $lowest_cost_key.

	my $obj = $$avltree->largest_oldest();  # get the deepest one	
	my $cost_key = $obj->$avl_get_key_func();
	my $data = $obj->$avl_get_data_func();
	return $obj;   
    }
}


# Return the shallowest, highest-cost leaf
sub shallowest_highest_cost_leaf
{
    my ($self, $best, $succ, $str_function) = @_;
    
    my $cost_hash_ref = $self->{_hash_of_trees_ref};
    my @cost_keys = (keys %$cost_hash_ref);
 
    my $cost_min_max_tree = $self->{_cost_min_max_tree};
      
    my $obj;

    if(!@cost_keys){
	return;
    }

    my $compare_func = sub{
	my ($obj1, $obj2) = @_;
	my $obj1_str = $str_function->($obj1);
	my $obj2_str = $str_function->($obj2);	
	if($obj1_str eq $obj2_str){
	    return 1;
	}
	return 0;
    };
    
    my $cmp_func = sub {
	my ($phrase) = @_;			
	return sub{
	    my ($obj) = @_;
	    my $obj_phrase = $str_function->($obj);
	    if($obj_phrase eq $phrase){
		return 1;
	    }
	    else{ 
		return 0; 
	    }	    
	}
    };	

    # get the highest cost from @cost_keys
  
    my $highest_cost_key = $cost_min_max_tree->largest();
    if(!$highest_cost_key){
	croak "shallowest_highest_cost_leaf_dont_remove: object not found in min-max heap\n";
    }

    if(!$cost_hash_ref->{$highest_cost_key}){
	# no tree for this cost.	     
	croak "shallowest_highest_cost_leaf: no tree at key $highest_cost_key\n";
	return;
    }
    else{
	my $least_depth = 0;
	my $avltree;