AI-Pathfinding-SMAstar
view release on metacpan or search on metacpan
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
use AI::Pathfinding::SMAstar::Path;
use Scalar::Util;
use Carp;
my $DEBUG = 0;
##################################################
# SMAstar constructor
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
_priority_queue => AI::Pathfinding::SMAstar::PriorityQueue->new(),
_state_eval_func => undef,
_state_goal_p_func => undef,
_state_num_successors_func => undef,
_state_successors_iterator => undef,
_show_prog_func => undef,
_state_get_data_func => undef,
@_, # attribute override
};
return bless $self, $class;
}
sub state_eval_func {
my $self = shift;
if (@_) { $self->{_state_eval_func} = shift }
return $self->{_state_eval_func};
}
sub state_goal_p_func {
my $self = shift;
if (@_) { $self->{_state_goal_p_func} = shift }
return $self->{_state_goal_p_func};
}
sub state_num_successors_func {
my $self = shift;
if (@_) { $self->{_state_num_successors_func} = shift }
return $self->{_state_num_successors_func};
}
sub state_successors_iterator {
my $self = shift;
if (@_) { $self->{_state_successors_iterator} = shift }
return $self->{_state_successors_iterator};
}
sub state_get_data_func {
my $self = shift;
if (@_) { $self->{_state_get_data_func} = shift }
return $self->{_state_get_data_func};
}
sub show_prog_func {
my $self = shift;
if (@_) { $self->{_show_prog_func} = shift }
return $self->{_show_prog_func};
}
###################################################################
#
# Add a state from which to begin the search. There can
# be multiple start-states.
#
###################################################################
sub add_start_state
{
my ($self, $state) = @_;
my $state_eval_func = $self->{_state_eval_func};
my $state_goal_p_func = $self->{_state_goal_p_func};
my $state_num_successors_func = $self->{_state_num_successors_func},
my $state_successors_iterator = $self->{_state_successors_iterator},
my $state_get_data_func = $self->{_state_get_data_func};
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
# add this node to the queue
$self->{_priority_queue}->insert($state_obj);
}
###################################################################
#
# start the SMAstar search process
#
###################################################################
sub start_search
{
my ($self,
$log_function,
$str_function,
$max_states_in_queue,
$max_cost,
) = @_;
if(!defined($str_function)){
croak "SMAstar start_search: str_function is not defined.\n";
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
#################################################################
#
# SMAstar search
# Memory-bounded A* search
#
#
#################################################################
sub sma_star_tree_search
{
my ($priority_queue,
$goal_p,
$successors_func,
$eval_func,
$backup_func,
$log_function, # debug string func; represent state object as a string.
$str_function,
$prog_function,
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
# removing and re-inserting in queue changes temporal ordering,
# and we don't want to do that unless the node will be
# placed in a new cost-bucket/tree.
# 2) then backup fvals
# 3) then re-insert best and all antecedents back on queue.
# Check if need for backup fvals
$best->check_need_fval_change();
my $cmp_func = sub {
my ($str) = @_;
return sub{
my ($obj) = @_;
my $obj_path_str = $str_function->($obj);
if($obj_path_str eq $str){
return 1;
}
else{
return 0;
}
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
#
# If best's descendants are all in memory, mark best as completed.
#
if($best->all_in_memory()) {
if(!($best->is_completed())){
$best->is_completed(1);
}
my $cmp_func = sub {
my ($str) = @_;
return sub{
my ($obj) = @_;
my $obj_str = $str_function->($obj);
if($obj_str eq $str){
return 1;
}
else{
return 0;
}
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
}
print "\n\nreturning unsuccessfully. iteration: $iteration\n";
return;
}
}
sub max
{
my ($n1, $n2) = @_;
return ($n1 > $n2 ? $n1 : $n2);
}
sub fp_compare {
my ($a, $b, $dp) = @_;
my $a_seq = sprintf("%.${dp}g", $a);
my $b_seq = sprintf("%.${dp}g", $b);
if($a_seq eq $b_seq){
return 0;
}
elsif($a_seq lt $b_seq){
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
use Tree::AVL;
use AI::Pathfinding::SMAstar::PairObj;
use Carp;
use strict;
##################################################
# AVLQueue constructor
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
_key => undef, # for comparisons with other queues, etc.
_avltree => Tree::AVL->new(fcompare => \&AI::Pathfinding::SMAstar::AVLQueue::compare_obj_counters,
fget_key => \&AI::Pathfinding::SMAstar::AVLQueue::obj_counter,
fget_data => \&AI::Pathfinding::SMAstar::AVLQueue::obj_value),
_counter => 0,
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
};
return bless $self, $class;
}
##############################################
# accessor
##############################################
sub key
{
my $self = shift;
if (@_) { $self->{_key} = shift }
return $self->{_key};
}
#############################################################################
#
# other methods
#
#############################################################################
sub get_keys_iterator
{
my ($self) = @_;
return $self->{_obj_counts_tree}->get_keys_iterator();
}
sub compare_obj_counters{
my ($obj, $arg_obj) = @_;
if ($arg_obj){
my $arg_key = $arg_obj->{_queue_counter};
my $key = $obj->{_queue_counter};
if($arg_key > $key){
return(-1);
}
elsif($arg_key == $key){
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
elsif($arg_key < $key){
return(1);
}
}
else{
croak "AVLQueue::compare_obj_counters: error: null argument object\n";
}
}
sub obj_counter{
my ($obj) = @_;
return $obj->{_queue_counter};
}
sub obj_value{
my ($obj) = @_;
return $obj->{_value};
}
sub compare {
my ($self, $arg_obj) = @_;
if ($arg_obj){
my $arg_key = $arg_obj->{_key};
my $key = $self->{_key};
if($arg_key > $key){
return(-1);
}
elsif($arg_key == $key){
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
}
elsif($arg_key < $key){
return(1);
}
}
else{
croak "AVLQueue::compare error: null argument object\n";
}
}
sub lookup {
my ($self, $obj) = @_;
my $found_obj = $self->{_avltree}->lookup_obj($obj);
if(!$found_obj){
croak "AVLQueue::lookup: did not find obj in queue\n";
return;
}
return $found_obj;
}
sub lookup_by_key {
my ($self, $key) = @_;
my $pair = AI::Pathfinding::SMAstar::PairObj->new(
_queue_counter => $key,
);
my $found_obj = $self->{_avltree}->lookup_obj($pair);
if(!$found_obj){
croak "AVLQueue::lookup: did not find obj in queue\n";
return;
}
return $found_obj;
}
sub remove {
my ($self, $obj, $compare_func) = @_;
my $found_obj;
$found_obj = $self->{_avltree}->remove($obj);
if(!$found_obj){
croak "AVLQueue::remove: did not find obj in queue\n";
return;
}
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
my $pairobj = AI::Pathfinding::SMAstar::PairObj->new(_key => $count,
_value => $count);
$self->{_obj_counts_tree}->remove($pairobj);
return $found_obj;
}
sub is_empty
{
my ($self) = @_;
if($self->{_avltree}->is_empty()){
return 1;
}
return 0;
}
sub insert
{
my ($self,
$obj) = @_;
my $count = $self->{_counter};
$obj->{_queue_counter} = $count;
$self->{_avltree}->insert($obj);
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
_value => $count);
$self->{_obj_counts_tree}->insert($pairobj);
$self->{_counter} = $self->{_counter} + 1;
return;
}
sub pop_top
{
my ($self) = @_;
my $top = $self->{_avltree}->pop_smallest();
my $count = $top->{_queue_counter};
my $pairobj = AI::Pathfinding::SMAstar::PairObj->new(_key => $count,
_value => $count);
$self->{_obj_counts_tree}->remove($pairobj);
return $top;
}
sub top
{
my ($self) = @_;
my $top = $self->{_avltree}->smallest();
return $top;
}
sub get_list{
my ($self) = @_;
return $self->{_avltree}->get_list();
}
sub get_size{
my ($self) = @_;
my $avltree = $self->{_avltree};
my $size = $avltree->get_size();
return $size;
}
sub print{
my ($self, $delim) = @_;
my @tree_elts = $self->{_avltree}->get_list();
foreach my $obj (@tree_elts){
print $obj->{_start_word} . ", " . $obj->{_phrase} . ", " . $obj->{_queue_counter} . "\n";
}
print "\n\nobj_counts_tree:\n";
$self->{_obj_counts_tree}->print("*");
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
use Tree::AVL;
use AI::Pathfinding::SMAstar::Examples::WordObj;
package AI::Pathfinding::SMAstar::Examples::PalUtils;
my $max_nodes_in_mem = 0;
sub length_no_spaces
{
my ($w) = @_;
$w =~ s/\ //g;
return length($w);
}
sub get_word_number_of_letters_that_have_repeats
{
my ($word) = @_;
my @letters = split('', $word);
my %letters_hash = ();
foreach my $element (@letters) { $letters_hash{$element}++ }
my $repeated_letters = 0;
foreach my $element (keys %letters_hash){
if($letters_hash{$element} > 1){
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
}
return $repeated_letters;
}
#
# finds the number of times each letter appears within
# an entire list of words. returns a hash of the letters
#
sub find_letter_frequencies
{
my (@words) = @_;
my %letters_freq;
foreach my $w (@words)
{
@letters = split('', $w);
foreach my $l (@letters)
{
$letters_freq{$l}++;
}
}
return %letters_freq;
}
sub collisions_per_length
{
my ($w, $phrase) = @_;
if(!$w){ $w = "" }
if(!$phrase){ $phrase = "" }
my $length = length($w);
$phrase =~ s/ //g;
my @letters = split('', $w);
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
}
}
my $val = $collisions/$length;
return $val;
}
sub get_word_sparsity
{
my ($word) = @_;
my $length = length($word);
my $num_letters = num_chars_in_word_memo($word);
my $sparseness = $length - $num_letters;
return $sparseness;
}
{ my %memo_cache;
sub get_word_sparsity_memo
{
my ($word) = @_;
if($memo_cache{$word}){
return $memo_cache{$word};
}
else{
my $length = length($word);
my $num_letters = num_chars_in_word_memo($word);
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
$memo_cache{$word} = $sparseness;
return $sparseness;
}
}
}
# get the highest number of times a letter
# is repeated within a word.
sub get_word_highest_frequency
{
my ($word) = @_;
my @letters = split('', $word);
my %letters_hash = ();
foreach my $element (@letters) { $letters_hash{$element}++ }
my $most_frequent_letter_freq = 0;
foreach my $element (keys %letters_hash){
if($letters_hash{$element} > $most_frequent_letter_freq){
$most_frequent_letter_freq = $letters_hash{$element};
}
}
return $most_frequent_letter_freq;
}
sub get_letters
{
my ($word) = @_;
my @letter_set = ();
my %letters_hash = ();
my @letters = split('', $word);
foreach my $element (@letters) { $letters_hash{$element}++ }
foreach my $element (keys %letters_hash)
{
push(@letter_set, $element);
}
return @letter_set;
}
{ my %memo_cache;
sub word_collision_memo
{
my ($word,
$sorted_letters_seen) = @_;
my $sorted_letters_seen_str = join('', @$sorted_letters_seen);
my $memo_key = $word . $sorted_letters_seen_str;
#print "sorted_letters_seen_str: $sorted_letters_seen_str\n";
if($memo_cache{$memo_key}){
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
$memo_cache{$memo_key} = \@answer;
return ($intersect_num, @difference);
}
}
}
sub word_collision{
my ($word,
$letters_seen) = @_;
my @letters = split('', $word);
my @difference = ();
my %letters_hash = ();
my %letters_seen_hash = ();
my $intersect_num = 0;
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
else{
push(@difference, $element);
}
}
return ($intersect_num, @difference);
}
sub get_cands_from_left
{
my ($word,
$dictionary,
$dictionary_rev) = @_;
my @cands = get_cands_memo($word, $dictionary_rev);
foreach my $c (@cands){
$c = reverse($c);
}
my @sorted_cands = sort(@cands);
return @sorted_cands;
}
sub get_cands_from_right
{
my ($word,
$dictionary,
$dictionary_rev) = @_;
my $rev_word = reverse($word);
my @cands = get_cands_memo($rev_word, $dictionary);
my @sorted_cands = sort(@cands);
return @sorted_cands;
}
{my $memo_hash_ref = {};
sub get_cands_memo
{
my ($word, $dictionary_rev) = @_;
my $cand = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $word
);
my $cache_key = $word . $dictionary_rev;
my $cached_vals = $memo_hash_ref->{$cache_key};
if($cached_vals){
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
\&AI::Pathfinding::SMAstar::Examples::WordObj::compare_up_to,
\&AI::Pathfinding::SMAstar::Examples::WordObj::compare);
my @cands = (@substr_cands, @superstr_cands);
# these are all the words in the dictionary that could end this pal.
$memo_hash_ref->{$cache_key} = \@cands;
return @cands;
}
}
}
sub get_cands
{
my ($word, $dictionary_rev) = @_;
my $cand = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $word
);
my @substr_cands = get_substrs_memo($word, $dictionary_rev);
my @superstr_cands = $dictionary_rev->acc_lookup($cand,
\&AI::Pathfinding::SMAstar::Examples::WordObj::compare_up_to,
\&AI::Pathfinding::SMAstar::Examples::WordObj::compare);
my @cands = (@substr_cands, @superstr_cands);
# these are all the words in the dictionary that could end this pal.
return @cands;
}
sub match_remainder
{
my ($word1, $word2) = @_;
$word1 =~ s/\ //g;
$word2 =~ s/\ //g;
my $len1 = length($word1);
my $len2 = length($word2);
if(index($word1, $word2) != 0)
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
my $remainder_word = substr($word1, $len2);
return $remainder_word;
}
#
# memoized version of get_substrs- for speed
#
{my $memo_hash_ref = {};
sub get_substrs_memo
{
my ($word, $dictionary) = @_;
my @words;
my @matches;
my $cache_key = $word . $dictionary;
my $cached_vals = $memo_hash_ref->{$cache_key};
if($cached_vals1){
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
}
#print "no hashed value yet, creating one.\n";
$memo_hash_ref->{$cache_key} = \@matches;
return @matches;
}
}
}
sub get_substrs
{
my ($word, $dictionary) = @_;
my @words;
my @matches;
for(my $i = 1; $i < length($word); $i++){
push(@words, substr($word, 0, $i));
}
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
push(@matches, $match_word);
}
}
return @matches;
}
# randomize an array. Accepts a reference to an array.
sub fisher_yates_shuffle {
my ($array) = @_;
my $i;
for ($i = @$array; --$i; ) {
my $j = int rand ($i+1);
next if $i == $j;
@$array[$i,$j] = @$array[$j,$i];
}
}
sub process_words
{
my ($words) = @_;
my @word_objs;
for(my $i = 0; $i < @$words; $i++)
{
my $word = $words->[$i];
chomp($word);
$word_objs[$i] = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $word,
);
}
return @word_objs;
}
sub process_words_by_density
{
my ($words,
$max_score # 0: no repeats, 1: 1 repeat, etc.
) = @_;
my @word_objs;
my $i = 0;
foreach my $word (@$words)
{
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
);
$i++;
}
}
return @word_objs;
}
sub process_rev_words
{
my ($words) = @_;
my @word_objs;
for(my $i = 0; $i < @$words; $i++)
{
my $word = $words->[$i];
chomp($word);
my $rev_word = reverse($word);
$word_objs[$i] = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $rev_word,
);
}
return @word_objs;
}
sub process_rev_words_by_density
{
my ($words,
$max_score # 0: no repeats, 1: 1 repeat, etc.
) = @_;
my @word_objs;
my $i = 0;
foreach my $word (@$words)
{
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
$word_objs[$i] = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $rev_word,
);
$i++;
}
}
return @word_objs;
}
sub is_palindrome
{
my ($candidate) = @_;
if(!$candidate){
return 0;
}
$candidate =~ s/\ //g;
return($candidate eq reverse($candidate));
}
sub join_strings
{
my ($strings) = @_;
my $candidate = join(' ', @$strings);
return $candidate;
}
sub make_one_word
{
my ($phrase) = @_;
$phrase =~ s/\s//g;
return $phrase;
}
sub num_chars_in_word
{
my ($word) = @_;
my %hash;
if(!$word) { return 0; }
@hash{ split '', $word} = 1;
my $num_keys = keys(%hash);
return $num_keys;
}
{my %memo_cache;
sub num_chars_in_word_memo
{
my ($word) = @_;
if($memo_cache{$word}){
return $memo_cache{$word};
}
else{
my %hash;
@hash{ split '', $word} = 1;
my $num_keys = keys(%hash);
$memo_cache{$word} = $num_keys;
return $num_keys;
}
}
}
{my %memo_cache;
sub num_chars_in_pal
{
my ($pal) = @_;
my $num_keys;
$pal =~ s/\ //g;
my $length = length($pal);
my $first_half = substr($pal, 0, $length/2 + 1);
if($memo_cache{$first_half}){
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
my %hash;
@hash{ split '', $first_half } = 1;
$num_keys = keys(%hash);
$memo_cache{$pal} = $num_keys;
return $num_keys;
}
}
}
sub read_dictionary
{
my ($in_file) = @_;
unless(open(READF, "+<$in_file")){
return;
}
my @lines = <READF>;
close(READF);
return @lines;
}
sub read_dictionary_filter_by_density
{
my ($in_file, $max_score) = @_;
unless(open(READF, "+<$in_file")){
return;
}
my @lines = <READF>;
my $num_lines = @lines;
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
if($sparsity <= $max_score){
$filtered_words[$i] = $word;
$i++;
}
}
return ($num_lines, @filtered_words);
}
sub read_dictionary_filter_by_density_rev
{
my ($in_file, $max_score) = @_;
unless(open(READF, "+<$in_file")){
return;
}
my @lines = <READF>;
my $num_lines = @lines;
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
$filtered_words[$i] = $rev_word;
$i++;
}
}
return ($num_lines, @filtered_words);
}
sub flush {
my $h = select($_[0]); my $a=$|; $|=1; $|=$a; select($h);
}
{my $spinny_thing = "-";
my $call_num = 0;
my $state;
sub show_progress {
$call_num++;
$state = $call_num % 4;
if($state == 0){
$spinny_thing = "-";
}
elsif($state == 1){
$spinny_thing = "\\";
}
elsif($state == 2){
$spinny_thing = "|";
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
my $percent = sprintf("%.2f", $progress*100);
$percent = $percent >= 100 ? '100.00%' : $percent.'%';
print("\r$stars $spinny_thing $percent.");
flush(STDOUT);
}
}
sub show_search_depth_and_percentage {
my ($depth, $so_far, $total) = @_;
my $stars = '*' x int($depth);
my $amount_completed = $so_far/$total;
my $percentage = sprintf("%0.2f", $amount_completed*100);
print("\r$stars depth: $depth. completed: $percentage %");
flush(STDOUT);
}
sub show_search_depth_and_num_states {
my ($depth, $states) = @_;
my $stars = '*' x int($depth);
my $num_states = @$states;
print("\rdepth: $depth. num_states: $num_states");
flush(STDOUT);
}
{my $LINES=`tput lines`; # number of rows in current terminal window
my $COLUMNS=`tput cols`; # number of columns in current terminal window
sub show_progress_so_far {
my ($iteration, $num_states, $str, $opt_datum, $opt_datum2) = @_;
my $stars = '*' x int($iteration);
# print "\e[H"; # Put the cursor on the first line
# print "\e[J"; # Clear from cursor to end of screen
# print "\e[H\e[J"; # Clear entire screen (just a combination of the above)
# print "\e[K"; # Clear to end of current line (as stated previously)
# print "\e[m"; # Turn off character attributes (eg. colors)
# printf "\e[%dm", $N; # Set color to $N (for values of 30-37, or 100-107)
lib/AI/Pathfinding/SMAstar/Examples/PalUtils.pm view on Meta::CPAN
print "\e[J"; #clears to end of screen
print "string: $str\e[J";
flush(STDOUT);
}
}
sub show_search_depth_and_num_states_debug {
}
{my $LINES=`tput lines`; # number of rows in current terminal window
my $COLUMNS=`tput cols`; # number of columns in current terminal window
sub show_progress_so_far_debug {
my ($depth, $prog, $num_states, $str, $num_successors) = @_;
my $stars = '*' x int($depth);
print "depth: $depth, string: $str, num_successors: $num_successors\n";
flush(STDOUT);
}
}
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
}
use vars qw($d $max_forgotten_nodes); # used to debug destroy method for accounting purposes
$d = 0;
$max_forgotten_nodes = 0;
##################################################
## the Phrase constructor
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
_word_list => undef,
_words_w_cands_list => undef,
_dictionary => undef,
_dictionary_rev => undef,
_start_word => undef, # remainder on cand for antecedent of this obj
_word => undef,
_cand => undef, # cand found for the antecedent of this obj
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
}
##############################################
## methods to access per-object data
##
## With args, they set the value. Without
## any, they only retrieve it/them.
##############################################
sub start_word {
my $self = shift;
if (@_) { $self->{_start_word} = shift }
return $self->{_start_word};
}
sub word {
my $self = shift;
if (@_) { $self->{_word} = shift }
return $self->{_word};
}
sub cand {
my $self = shift;
if (@_) { $self->{_cand} = shift }
return $self->{_cand};
}
sub antecedent{
my $self = shift;
if (@_) { $self->{_predecessor} = shift }
return $self->{_predecessor};
}
sub dir{
my $self = shift;
if (@_) { $self->{_dir} = shift }
return $self->{_dir};
}
sub match_remainder_left{
my $self = shift;
if (@_) { $self->{_match_remainder_left} = shift }
return $self->{_match_remainder_left};
}
sub match_remainder_right {
my $self = shift;
if (@_) { $self->{_match_remainder_right} = shift }
return $self->{_match_remainder_right};
}
sub intersect_threshold {
my $self = shift;
if (@_) { $self->{_intersect_threshold} = shift }
return $self->{_intersect_threshold};
}
sub max_collisions{
my $self = shift;
if (@_) { $self->{_max_collisions} = shift }
return $self->{_max_collisions};
}
sub letters_seen{
my $self = shift;
if (@_) { $self->{_letters_seen} = shift }
return $self->{_letters_seen};
}
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};
}
sub compare
{
my ($min_letters) = @_;
return sub{
my ($self, $arg_obj) = @_;
my $self_eval_func = evaluate($min_letters);
my $argobj_eval_func = evaluate($min_letters);
my $self_eval = $self->$self_eval_func;
my $arg_obj_eval = $arg_obj->$argobj_eval_func;
return $self_eval - $arg_obj_eval;
}
}
sub compare_by_depth
{
my ($self, $arg_obj) = @_;
my $self_depth = $self->{_depth};
my $argobj_depth = $arg_obj->{_depth};
my $result = $self_depth - $argobj_depth;
return $result;
}
# compare_phrase_word_strings
#
# usage: $phrase_obj->compare_phrase_word_strings($other_word_obj)
#
# Accepts another Phrase object as an argument.
# Returns 1 if greater than argument, 0 if equal, and -1 if
# less than argument
sub compare_phrase_word_strings
{
my ($self, $arg_obj) = @_;
my $arg_phrase_plus_word = $arg_obj->{_phrase} . $arg_obj->{_word};
my $phrase_plus_word = $self->{_phrase} . $self->{_word};
if($arg_phrase_plus_word gt $phrase_plus_word){
return -1;
}
elsif($arg_phrase_plus_word eq $phrase_plus_word){
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
#----------------------------------------------------------------------------
# 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 evaluate
{
my ($min_num_letters) = @_;
return sub{
my ($self) = @_;
# if fcost has already been calculated (or reassigned during a backup)
# then return it. otherwise calculate it
my $fcost = $self->{_f_cost};
if(defined($fcost)){
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
my $distance_from_goal = $min_num_letters - ($num_chars_so_far + $num_new_chars); #1 optimistic/admissible
my $evaluation = $total_cost + $distance_from_goal;
$self->{_f_cost} = $evaluation;
return $evaluation;
}
}
#-----------------------------------------------------------------------------
sub phrase_is_palindrome_min_num_chars
{
my ($min_num_chars) = @_;
return sub{
my ($self) = @_;
my $phrase = $self->{_phrase};
if(AI::Pathfinding::SMAstar::Examples::PalUtils::is_palindrome($phrase) &&
(AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_pal($phrase) >= $min_num_chars)){
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
}
else{
return 0;
}
}
}
#----------------------------------------------------------------------------
sub letters_seen_so_far
{
my ($self) = @_;
my $num_letters_seen = $self->{_num_chars_so_far};
return $num_letters_seen;
}
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
#-----------------------------------------------------------------------------
# Get descendants iterator function.
# Generate the next descendant of a phrase object. Each descendant adds
# another word to the phrase that could possibly lead to a palindrome
#
#-----------------------------------------------------------------------------
sub get_descendants_iterator
{
my ($phrase_obj) = @_;
if(!$phrase_obj){
return;
}
my $words = $phrase_obj->{_word_list};
my $words_w_cands = $phrase_obj->{_words_w_cands_list};
my $dictionary = $phrase_obj->{_dictionary};
my $dictionary_rev = $phrase_obj->{_dictionary_rev};
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
}
}
}
#-----------------------------------------------------------------------------
# Return the number of successors of this phrase
#-----------------------------------------------------------------------------
sub get_num_successors
{
my ($self) = @_;
my $num_successors = 0;
my $iterator = $self->get_descendants_num_iterator();
while(my $next_descendant = $iterator->()){
$num_successors++;
}
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
#-----------------------------------------------------------------------------
# Get descendants number function.
#
#
#
#-----------------------------------------------------------------------------
sub get_descendants_number
{
my ($phrase_obj) = @_;
if(!$phrase_obj){
return;
}
my $words = $phrase_obj->{_word_list};
my $words_w_cands = $phrase_obj->{_words_w_cands_list};
my $dictionary = $phrase_obj->{_dictionary};
my $dictionary_rev = $phrase_obj->{_dictionary_rev};
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
}
#-----------------------------------------------------------------------------
# Get descendants iterator function.
# Generate the next descendant of a phrase object. Each descendant adds
# another word to the phrase that could possibly lead to a palindrome
#
#-----------------------------------------------------------------------------
sub get_descendants_num_iterator
{
my ($phrase_obj) = @_;
if(!$phrase_obj){
return;
}
my $words = $phrase_obj->{_word_list};
my $words_w_cands = $phrase_obj->{_words_w_cands_list};
my $dictionary = $phrase_obj->{_dictionary};
my $dictionary_rev = $phrase_obj->{_dictionary_rev};
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
#-----------------------------------------------------------------------------
# traverse from candidate phrase-object back up to start word, building up the
# phrase string. iterative version.
#-----------------------------------------------------------------------------
sub roll_up_phrase
{
my ($pobj, $phrase, $depth) = @_; # depth == depth of recursion
if(!$depth){
$depth = 0;
}
while($pobj){
if(!$pobj->{_cand} && $depth == 0){
# top-level call to roll_up_phrase is called on a root node.
lib/AI/Pathfinding/SMAstar/Examples/Phrase.pm view on Meta::CPAN
$depth++;
} # end while($pobj);
return $phrase;
}
sub roll_up_phrase_plus_word
{
my ($self) = @_;
my $phrase = $self->{_phrase};
my $word = $self->{_start_word};
my $phrase_plus_cand = $phrase . ": " . $word;
return $phrase_plus_cand;
}
sub DESTROY
{
my ($self) = @_;
my $antecedent;
my $ant_phrase;
my ($pkg, $filename, $line_num) = caller();
if($self->{_predecessor}){
$antecedent = $self->{_predecessor};
lib/AI/Pathfinding/SMAstar/Examples/WordObj.pm view on Meta::CPAN
package AI::Pathfinding::SMAstar::Examples::WordObj;
use strict;
##################################################
## the object constructor (simplistic version) ##
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
_word => undef,
@_, # Override previous attributes
};
return bless $self, $class;
}
##############################################
## methods to access per-object data ##
## ##
## With args, they set the value. Without ##
## any, they only retrieve it/them. ##
##############################################
sub word {
my $self = shift;
if (@_) { $self->{_word} = shift }
return $self->{_word};
}
# compare
#
# usage: $word_obj->compare($other_word_obj)
#
# Accepts another WordObj object as an argument.
# Returns 1 if greater than argument, 0 if equal, and -1 if
# less than argument
sub compare{
my ($self,$arg_wordobj) = @_;
my $arg_word = $arg_wordobj->{_word};
my $word = $self->{_word};
if($arg_word gt $word){
return -1;
}
elsif($arg_word eq $word){
return 0;
lib/AI/Pathfinding/SMAstar/Examples/WordObj.pm view on Meta::CPAN
# compare_up_to
#
# usage: $word_obj->compare_up_to($other_word_obj)
#
# Accepts another WordObj object as an argument.
# Returns 1 if greater than argument, 0 if $other_word_obj
# is a substring of $word_obj
# that appears at the beginning of $word_obj
# and -1 if less than argument $other_word_obj
sub compare_up_to{
my $self = shift;
if (@_){
my $arg_wordobj = shift;
my $arg_word = $arg_wordobj->{_word};
my $word = $self->{_word};
# perl's index function works like: index($string, $substr);
if(index($word, $arg_word) == 0){
return(0);
}
lib/AI/Pathfinding/SMAstar/Examples/WordObj.pm view on Meta::CPAN
# compare_up_to
#
# usage: $word_obj->compare_down_to($other_word_obj)
#
# Returns 0 if $word_obj is a substring of
# $other_word_obj, that appears at the beginning
# of $other_word_obj.
#
sub compare_down_to{
my $self = shift;
if (@_){
my $arg_wordobj = shift;
my $arg_word = $arg_wordobj->{_word};
my $word = $self->{_word};
# perl's index function works like: index($string, $substr);
if(index($arg_word, $word) == 0){
return(0);
}
lib/AI/Pathfinding/SMAstar/PairObj.pm view on Meta::CPAN
package AI::Pathfinding::SMAstar::PairObj;
use strict;
##################################################
# PairObj constructor
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
_key => undef,
_value => undef,
@_, # Override previous attributes
};
return bless $self, $class;
}
##############################################
# accessors
##############################################
sub value {
my $self = shift;
if (@_) { $self->{_value} = shift }
return $self->{_value};
}
sub val {
my $self = shift;
if (@_) { $self->{_value} = shift }
return $self->{_value};
}
sub key {
my $self = shift;
if (@_) { $self->{_key} = shift }
return $self->{_key};
}
# compare_vals
#
# usage: $pair_obj->compare($other_pair_obj)
#
# Accepts another PairObj object as an argument.
# Returns 1 if greater than argument, 0 if equal, and -1 if
# less than argument
sub compare_vals{
my ($self,$arg_obj) = @_;
my $arg_value = $arg_obj->{_value};
my $value = $self->{_value};
if($arg_value gt $value){
return -1;
}
elsif($arg_value eq $value){
return 0;
lib/AI/Pathfinding/SMAstar/PairObj.pm view on Meta::CPAN
}
# compare_keys
#
# usage: $pair_obj->compare($other_pair_obj)
#
# Accepts another PairObj object as an argument.
# Returns 1 if greater than argument, 0 if equal, and -1 if
# less than argument
sub compare_keys{
my ($self,$arg_obj) = @_;
my $arg_key = $arg_obj->{_key};
my $key = $self->{_key};
if($arg_key gt $key){
return -1;
}
elsif($arg_key eq $key){
return 0;
}
return 1;
}
sub compare_keys_numeric{
my ($self,$arg_obj) = @_;
my $arg_key = $arg_obj->{_key};
my $key = $self->{_key};
if($arg_key > $key){
return -1;
}
elsif($self->fp_equal($arg_key, $key, 10)){
return 0;
}
return 1;
}
sub fp_equal {
my ($self, $A, $B, $dp) = @_;
return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}
1; # so the require or use succeeds
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
}
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,
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
};
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;
}
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
#----------------------------------------------------------------------------
# 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;
}
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
#-----------------------------------------------------------------------------------------------
#
# 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;
}
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
#
# return 1 if all descendants of this path are in
# memory, return 0 otherwise.
#
sub all_in_memory
{
my ($self) = @_;
my $is_completed = $self->is_completed();
my $num_successors_in_mem = $self->{_num_successors_in_mem};
my $num_successors = $self->{_num_successors};
my $num_forgotten_fcosts = @{$self->{_forgotten_node_fcosts}};
if($is_completed || $num_successors == 0){
if($num_successors == $num_successors_in_mem){
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
return 0;
}
return 0;
}
#
# return 1 if *any* descendants are in memory
#
sub has_descendants_in_memory
{
my ($self) = @_;
my $num_descendants_on_queue = $self->{_descendants_on_queue};
if($num_descendants_on_queue){
return $num_descendants_on_queue;
}
return;
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
#-----------------------------------------------------------------------------
# Get descendants iterator function, for for SMA* search. Returns one new
# node at a time.
#
# The SMA* algorithm must handle "forgotten" nodes.
#
# Generate the next descendant of a path object. Each descendant adds
# another node on the path that may lead to the goal.
#
#-----------------------------------------------------------------------------
sub get_descendants_iterator_smastar
{
my ($self) = @_;
my $depth = $self->{_depth};
my $iterator;
my $num_successors = 0;
my $next_descendant;
# if we haven't counted the number of successors yet,
# count and record the number, so we only have to do
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
}
else{
# if number of successors has already been recorded, update
# num_successors variable with stored value.
$num_successors = $self->{_num_successors};
}
return sub{
my $i = 0;
# entering get_descendants_iterator_smastar() sub
$iterator = $self->get_successors_iterator();
my $descendants_deleted = 0;
my $descendants_found = 0;
# loop over nodes returned by iterator
while(my $next_state = $iterator->()){
$next_descendant = AI::Pathfinding::SMAstar::Path->new(
lib/AI/Pathfinding/SMAstar/Path.pm view on Meta::CPAN
# no next successor found
$self->is_completed(1);
}
return $next_descendant;
}
}
sub get_data
{
my ($self) = @_;
my $get_data_func = $self->{_get_data_func};
my $data = $get_data_func->($self->{_state});
return $data;
}
sub DESTROY
{
my ($self) = @_;
# antecedent is no longer pointing at this object, or else
# DESTROY would not have been called.
if($self->{_antecedent}){
delete $self->{_antecedent};
}
}
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
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};
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
}
$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";
}
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
}
}
#-----------------------------------
# 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};
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
}
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){
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
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);
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
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;
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
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;
}
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
}
return $obj;
}
else{
return;
}
}
}
sub largest_element
{
my ($array) = @_;
if(!@$array){
return;
}
else{
my $i = 0;
my $largest = $$array[$i];
for($i = 1; $i < @$array; $i++)
{
if($largest < $$array[$i]){
$largest = $$array[$i];
}
}
return $largest;
}
}
sub next_largest_element
{
my ($array, $val) = @_;
if(!@$array){
return;
}
else{
my $i = 0;
my $largest = -1;
for($i = 0; $i < @$array; $i++)
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
return $largest;
}
else{
return;
}
}
}
sub next_smallest_non_zero_element
{
my ($array, $val) = @_;
my $max = 2^32-1;
if(!@$array){
return;
}
else{
my $i = 0;
lib/AI/Pathfinding/SMAstar/PriorityQueue.pm view on Meta::CPAN
if($smallest != $max){
return $smallest;
}
else{
return;
}
}
}
sub smallest_element
{
my ($array) = @_;
if(!@$array){
return;
}
else{
my $i = 0;
my $smallest = $$array[$i];
for($i = 1; $i < @$array; $i++){
if($smallest > $$array[$i]){
$smallest = $$array[$i];
}
}
return $smallest;
}
}
sub get_size{
my ($self) = @_;
my $cost_hash_ref = $self->{_hash_of_trees_ref};
my $size = 0;
foreach my $key (keys %$cost_hash_ref){
my $tree = $cost_hash_ref->{$key};
my $tree_size = $$tree->get_size();
$size += $tree_size;
}
return $size;
}
sub fp_compare
{
my ($obj1, $obj2) = @_;
if(fp_equal($obj1, $obj2, 10)){
return 0;
}
if($obj1 < $obj2){
return -1;
}
return 1;
}
sub fp_equal {
my ($A, $B, $dp) = @_;
return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
#
package AI::Pathfinding::SMAstar::TreeOfQueues;
use strict;
use Tree::AVL;
use AI::Pathfinding::SMAstar::AVLQueue;
##################################################
# TreeOfQueues constructor
##################################################
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {
f_avl_compare => undef,
f_obj_get_key => undef,
f_obj_get_data => undef,
_avl_tree => Tree::AVL->new(fcompare => \&AI::Pathfinding::SMAstar::AVLQueue::compare,
fget_key => \&AI::Pathfinding::SMAstar::AVLQueue::key,
fget_data => \&AI::Pathfinding::SMAstar::AVLQueue::key),
@_, # attribute override
};
return bless $self, $class;
}
sub insert{
my ($self, $obj) = @_;
# check to see if there is a Queue in the tree with the key of obj.
# if not, create one and insert
my $fget_key = $self->{f_obj_get_key};
my $avl_compare = $self->{f_avl_compare};
my $key = $obj->$fget_key();
my $queue = AI::Pathfinding::SMAstar::AVLQueue->new(_key => $key);
my $found_queue = $self->{_avl_tree}->lookup_obj($queue);
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
if(!$found_queue){
$self->{_avl_tree}->insert($queue); # insert queue, with no duplicates
$queue->insert($obj); # insert object onto new queue
}
else { # found a queue here. insert obj
$found_queue->insert($obj);
}
}
sub remove{
my ($self, $obj, $cmp_func) = @_;
# check to see if there is a Queue in the tree with the key of obj.
# if not, create one and insert
my $fget_key = $self->{f_obj_get_key};
my $avl_compare = $self->{f_avl_compare};
my $key = $obj->$fget_key();
my $queue = AI::Pathfinding::SMAstar::AVLQueue->new(_key => $key);
my $avltree = \$self->{_avl_tree};
my $found_queue = $self->{_avl_tree}->lookup_obj($queue);
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
else { # found a queue here. remove obj
#print "TreeOfQueues::remove: found queue, removing obj using $cmp_func\n";
$found_queue->remove($obj, $cmp_func);
if($found_queue->is_empty()){
#print "TreeOfQueues::remove: found queue is now empty, removing queue from tree\n";
$$avltree->remove($found_queue);
}
}
}
sub largest_oldest{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
# $$avltree->print("-");
# get the avl tree with the largest key
my $queue = $$avltree->largest();
if($queue){
my $key = $queue->key();
my $obj = $queue->top();
return $obj;
}
else{
return;
}
}
sub pop_largest_oldest{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
# $$avltree->print("*");
# get the avl tree with the largest key
my $queue = $$avltree->largest();
if($queue){
my $key = $queue->key();
my $obj = $queue->pop_top();
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
if($queue->is_empty()){
$$avltree->remove($queue);
}
return $obj;
}
else{
return;
}
}
sub smallest_oldest{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
# $$avltree->print("-");
# get the avl tree with the largest key
my $queue = $$avltree->smallest();
if($queue){
my $key = $queue->key();
my $obj = $queue->top();
return $obj;
}
else{
return;
}
}
sub pop_smallest_oldest{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
# $$avltree->print("*");
# get the avl tree with the largest key
my $queue = $$avltree->smallest();
if($queue){
my $key = $queue->key();
my $obj = $queue->pop_top();
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
$$avltree->remove($queue);
}
return $obj;
}
else{
return;
}
}
sub pop_oldest_at{
my ($self, $key) = @_;
my $avltree = \$self->{_avl_tree};
my $queue_to_find = AI::Pathfinding::SMAstar::AVLQueue->new(_key => $key);
my $queue = $$avltree->lookup_obj($queue_to_find);
if($queue){
# print "TreeOfQueues::pop_oldest_at: found queue with key: $key\n";
my $obj = $queue->pop_top();
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
}
else{
# print "TreeOfQueues::pop_oldest_at: did not find queue with key: $key\n";
return;
}
}
sub oldest_at{
my ($self, $key) = @_;
my $avltree = \$self->{_avl_tree};
my $queue_to_find = AI::Pathfinding::SMAstar::AVLQueue->new(_key => $key);
my $queue = $$avltree->lookup_obj($queue_to_find);
if($queue){
# print "TreeOfQueues::oldest_at: found queue with key: $key\n";
my $obj = $queue->top();
return $obj;
}
else{
# print "TreeOfQueues::oldest_at: did not find queue with key: $key\n";
return;
}
}
sub largest{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
return $$avltree->largest();
}
sub get_queue{
my ($self, $key) = @_;
my $avltree = \$self->{_avl_tree};
my $queue_to_find = AI::Pathfinding::SMAstar::AVLQueue->new(_key => $key);
my $queue = $$avltree->lookup_obj($queue_to_find);
if($queue){
# print "TreeOfQueues::get_queue: found queue with key: $key\n";
return $queue;
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
else{
# print "TreeOfQueues::get_queue: did not find queue with key: $key\n";
return;
}
}
sub get_keys_iterator
{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
return $$avltree->get_keys_iterator();
}
sub get_keys
{
my ($self) = @_;
my $avltree = \$self->{_avl_tree};
return $$avltree->get_keys();
}
sub print{
my ($self) = @_;
if($self->{_avl_tree}->is_empty()){
print "tree is empty\n";
}
my $get_key_func = $self->{f_obj_get_key};
my $get_data_func = $self->{f_obj_get_data};
my @queue_list = $self->{_avl_tree}->get_list();
lib/AI/Pathfinding/SMAstar/TreeOfQueues.pm view on Meta::CPAN
my $key = $obj->$get_key_func;
my $word = $obj->$get_data_func;
print " key: $key, data: $word\n";
}
}
}
sub is_empty{
my ($self) = @_;
if($self->{_avl_tree}->is_empty()){
return 1;
}
return 0;
}
sub get_size{
my ($self) = @_;
my $size = 0;
if($self->{_avl_tree}->is_empty()){
return $size;
}
my @queue_list = $self->{_avl_tree}->get_list();
foreach my $queue (@queue_list){
$size = $size + $queue->get_size();
}
return $size;
}
sub get_list{
my ($self) = @_;
my @objs;
if($self->{_avl_tree}->is_empty()){
return;
}
#$self->{_avl_tree}->print(">>>");
t/AI-Pathfinding-SMAstar.t view on Meta::CPAN
###########################################################################
#
# Auxiliary functions
#
###########################################################################
#----------------------------------------------------------------------------
sub log_function
{
my ($path_obj) = @_;
if(!$path_obj){
my ($pkg, $filename, $line) = caller();
print "$pkg, $filename, $line\n";
t/AI-Pathfinding-SMAstar.t view on Meta::CPAN
return $log_str;
}
#----------------------------------------------------------------------------
sub str_function
{
my ($path_obj) = @_;
my $sw = defined($path_obj->{_state}->{_start_word}) ? $path_obj->{_state}->{_start_word} : "";
my $phrase = defined($path_obj->{_state}->{_phrase}) ? $path_obj->{_state}->{_phrase} : "";
my $str = "$sw, $phrase";
return $str;
}
t/AI-Pathfinding-SMAstar.t view on Meta::CPAN
sub flush {
my $h = select($_[0]); my $a=$|; $|=1; $|=$a; select($h);
}
{my $spinny_thing = "-";
my $call_num = 0;
my $state;
sub show_progress {
$call_num++;
$state = $call_num % 4;
if($state == 0){
$spinny_thing = "-";
}
elsif($state == 1){
$spinny_thing = "\\";
}
elsif($state == 2){
$spinny_thing = "|";
( run in 0.286 second using v1.01-cache-2.11-cpan-4d50c553e7e )