AI-Pathfinding-SMAstar
view release on metacpan or search on metacpan
Revision history for Perl extension AI::Pathfinding::SMAstar.
0.01 Tue Feb 23 12:06:47 2010
- original version; created by h2xs 1.23 with options
-XAn AI::Pathfinding::SMAstar
0.02 Fri Feb 25 11:17:01 2010
- updated pod documentation
0.03 Sun Feb 28 12:26:58 2010
- updated pod documentation
0.04 Tue Mar 2 13:17:53 2010
- updated error handling in add_start_state method
- perldoc edits
0.05 Thu Mar 4 11:06:10 2010
- fixed an issue where search did not terminate when max_cost
is reached.
0.06 Thu Mar 4 11:06:10 2010
- fixed an issue with successor iterator in Path class.
--- #YAML:1.0
name: AI-Pathfinding-SMAstar
version: 0.07
abstract: Simplified Memory-bounded A* Search
license: ~
author:
- Matthias Beebe <mbeebe@cpan.org>
generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
Test::More: 0
Tree::AVL: 0
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
Makefile.PL view on Meta::CPAN
use 5.006000;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
NAME => 'AI::Pathfinding::SMAstar',
VERSION_FROM => 'lib/AI/Pathfinding/SMAstar.pm', # finds $VERSION
PREREQ_PM => {Test::More => 0,
Tree::AVL => 0,}, # e.g., Module::Name => 1.1
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'lib/AI/Pathfinding/SMAstar.pm', # retrieve abstract from module
AUTHOR => 'Matthias Beebe <mbeebe@cpan.org>') : ()),
);
AI-Pathfinding-SMAstar version 0.07
===================================
NAME
AI::Pathfinding::SMAstar - Memory-bounded A* Search
SYNOPSIS
use AI::Pathfinding::SMAstar;
EXAMPLE
##################################################################
#
# This example uses a hypothetical object called FrontierObj, and
# shows the functions that FrontierObj must feature in order to
# perform a path search in a solution-space populated by
# FrontierObj objects.
#
##################################################################
my $smastar = AI::Pathfinding::SMAstar->new(
# evaluates f(n) = g(n) + h(n), returns a number
_state_eval_func => \&FrontierObj::evaluate,
# when called on a node, returns 1 if it is a goal
_state_goal_p_func => \&FrontierObj::goal_test,
# must return the number of successors of a node
_state_num_successors_func => \&FrontierObj::get_num_successors,
# must return *one* successor at a time
_state_successors_iterator => \&FrontierObj::get_successors_iterator,
# can be any suitable string representation
_state_get_data_func => \&FrontierObj::string_representation,
# gets called once per iteration, useful for showing algorithm progress
_show_prog_func => \&FrontierObj::progress_callback,
);
# you can start the search from multiple start-states
# Add the initial states to the smastar object before starting the search.
foreach my $frontierObj (@start_states){
$smastar->add_start_state($frontierObj);
}
# Start the search. If successful, frontierGoalObj will contain the
# goal node. The optimal path to the goal node will be encoded in the
# ancestry of the goal node. $frontierGoalObj->antecedent() contains
# the goal object's parent, and so forth back to the start state.
my $frontierGoalObj = $smastar->start_search(
\&log_function, # returns a string used for logging progress
\&str_function, # returns a string used to *uniquely* identify a node
$max_states_in_queue, # indicate the maximum states allowed in memory
$MAX_COST, # indicate the maximum cost allowed in search
);
Explanation
In the example above, a hypothetical object, FrontierObj, is used to
represent a node in your search space. To use SMA* search to find a shortest
path from a starting node to a goal in your search space, you must define what
a node is, in your search space (or point, or state).
A common example used for informed search methods, and one that is
used in Russell's original paper, is a N-puzzle, such as an 8-puzzle or
15-puzzle. If trying to solve such a puzzle, a node in the search space
could be defined as a particular configuration of that puzzle. In the
/t directory of this module's distribution, SMA* is applied to the problem
of finding the shortest palindrome that contains a minimum number of letters
specified, over a given lexicon of words.
Once you have a definition and representation of a node in your search space, SMA*
search requires the following functions to work:
** State evaluation function (_state_eval_func above)
This function must return the cost of this node in the search space. In all
forms of A* search, this means the cost paid to arrive at this node along a path,
plus the estimated cost of going from this node to a goal state. This function
must be positive and monotonic, meaning that successor nodes mustn't be less
expensive than their antecedent nodes. Monotonicity is ensured in this implementation
of SMA*, so even if your function is not monotonic, SMA* will assign the antecedent
node's cost to a successor if that successor costs less than the antecedent.
* State goal predicate function (_state_goal_p_func above)
This function must return 1 if the node is a goal node, or 0 otherwise.
* State number of successors function (_state_num_successors_func above)
This function must return the number of successors of this node, i.e. all
nodes that are reachable from this node via a single operation.
* State successors iterator (_state_iterator above)
This function must return a *handle to a function* that returns next
successor of this node, i.e. it must return an iterator that produces
the successors of this node *one* at a time. This is
necessary to maintain the memory-bounded constraint of SMA* search.
* State get-data function (_state_get_data_func above)
This function returns a string representation of this node.
* State show-progress function (_show_prog_func above)
This is a callback function for displaying the progress of the
search. It can be an empty callback if you do not need this output.
* log string function (log_function above)
This is an arbitrary string used for logging. It also gets passed to
the show-progress function above.
* str_function (str_function above)
This function returns a *unique* string representation of this node.
Uniqueness is required for SMA* to work properly.
* max states allowed in memory (max_states_in_queue above)
An integer indicating the maximum number of expanded nodes to
hold in memory at any given time.
* maximum cost (MAX_COST above)
An integer indicating the maximum cost, beyond which nodes will not be
expanded.
DESCRIPTION
Overview
Memory-bounded A* search (or SMA* search) addresses some of the limitations of
conventional A* search, by bounding the amount of space required to perform a
shortest-path search. This module is an implementation of SMA*, which was first
always find a path to the goal if such a path exists.
In general, A* search works using a calculated cost function on each node
along a path, in addition to an admissible heuristic estimating the distance
from that node to the goal. The cost is calculated as:
f(n) = g(n) + h(n)
Where:
* n is a state (node) along a path
* g(n) is the total cost of the path leading up to n
* h(n) is the heuristic function, or estimated cost of the path from n
to the goal node.
The to be admissible, the heuristic must never over-estimate the distance
from the node to the goal. If the heuristic is set to zero, A* search reduces
to Branch and Bound search.
For a given heuristic function, it can be shown that A* search is optimally
efficient, meaning that, in its calculation of the shortest path, it expands
fewer nodes in the search space than any other algorithm.
The space complexity of A* search is bounded by an exponential of the
memory for search without any danger of overflow. It can, however, make SMA*
search significantly slower than a theoretical unbounded-memory search, due to
the extra bookkeeping it must do, and because nodes may need to be re-expanded
(the overall number of node expansions may increase).
It can be shown that of the memory-bounded variations of A* search, such MA*,
IDA*, Iterative Expansion, etc., SMA* search expands the least number of nodes
on average. However, for certain classes of problems, guaranteeing optimality
can be costly. This is particularly true in solution spaces where:
* the branching factor of the search space is large
* there are multiple equivalent optimal solutions (or shortest paths)
For solution spaces with these characteristics, stochastic methods or
approximation algorithms such as Simulated Annealing can provide a massive
reduction in time and space requirements, while introducing a tunable
probability of producing a sub-optimal solution.
METHODS
AUTHOR
Matthias Beebe, <mbeebe@cpan.org>
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
This module requires these other modules and libraries:
Tree::AVL
Test::More
COPYRIGHT AND LICENCE
Copyright (C) 2010 by Matthias Beebe
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself, either Perl version 5.10.0 or, at
your option, any later version of Perl 5 you may have available.
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use AI::Pathfinding::SMAstar ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.07';
use AI::Pathfinding::SMAstar::PriorityQueue;
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};
# make sure required functions have been defined
if(!defined($state_eval_func)){
croak "SMAstar: evaluation function is not defined\n";
}
if(!defined($state_goal_p_func)){
croak "SMAstar: goal function is not defined\n";
}
if(!defined($state_num_successors_func)){
croak "SMAstar: num successors function is not defined\n";
}
if(!defined($state_successors_iterator)){
croak "SMAstar: successor iterator is not defined\n";
}
# create a path object from this state
my $state_obj = AI::Pathfinding::SMAstar::Path->new(
_state => $state,
_eval_func => $state_eval_func,
_goal_p_func => $state_goal_p_func,
_num_successors_func => $state_num_successors_func,
_successors_iterator => $state_successors_iterator,
_get_data_func => $state_get_data_func,
);
my $fcost = AI::Pathfinding::SMAstar::Path::fcost($state_obj);
# check if the fcost of this node looks OK (is numeric)
unless(Scalar::Util::looks_like_number($fcost)){
croak "Error: f-cost of state is not numeric. Cannot add state to queue.\n";
}
$state_obj->f_cost($fcost);
# check if the num_successors function returns a number
my $num_successors = $state_obj->get_num_successors();
unless(Scalar::Util::looks_like_number($num_successors)){
croak "Error: Number of state successors is not numeric. Cannot add state to queue.\n";
}
# test out the iterator function to make sure it returns
# an object of the correct type
my $classname = ref($state);
my $test_successor_iterator = $state_obj->{_successors_iterator}->($state);
my $test_successor = $test_successor_iterator->($state);
my $succ_classname = ref($test_successor);
unless($succ_classname eq $classname){
croak "Error: Successor iterator method of object $classname does " .
"not return an object of type $classname.\n";
}
# 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";
}
sma_star_tree_search(\($self->{_priority_queue}),
\&AI::Pathfinding::SMAstar::Path::is_goal,
\&AI::Pathfinding::SMAstar::Path::get_descendants_iterator_smastar,
\&AI::Pathfinding::SMAstar::Path::fcost,
\&AI::Pathfinding::SMAstar::Path::backup_fvals,
$log_function,
$str_function,
\&AI::Pathfinding::SMAstar::Path::progress,
$self->{_show_prog_func},
$max_states_in_queue,
$max_cost,
);
}
#################################################################
#
# 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,
$show_prog_func,
$max_states_in_queue,
$max_cost,
) = @_;
my $iteration = 0;
my $num_states_in_queue = $$priority_queue->size();
my $max_extra_states_in_queue = $max_states_in_queue;
$max_states_in_queue = $num_states_in_queue + $max_extra_states_in_queue;
my $max_depth = ($max_states_in_queue - $num_states_in_queue);
my $best; # the best candidate for expansion
if($$priority_queue->is_empty() || !$$priority_queue){
return;
}
else{
my $num_successors = 0;
# loop over the elements in the priority queue
while(!$$priority_queue->is_empty()){
# determine the current size of the queue
my $num_states_in_queue = $$priority_queue->{_size};
# get the best candidate for expansion from the queue
$best = $$priority_queue->deepest_lowest_cost_leaf_dont_remove();
#------------------------------------------------------
if(!$DEBUG){
my $str = $log_function->($best);
$show_prog_func->($iteration, $num_states_in_queue, $str);
}
else{
my $str = $log_function->($best);
print "best is: " . $str_function->($best) . ", cost: " . $best->{_f_cost} . "\n";
}
#------------------------------------------------------
if($best->$goal_p()) {
# goal achieved! iteration: $iteration, number of
# states in queue: $num_states_in_queue.
return $best;
}
elsif($best->{_f_cost} >= $max_cost){
croak "\n\nSearch unsuccessful. max_cost reached (cost: $max_cost).\n";
}
else{
my $successors_iterator = $best->$successors_func();
my $succ = $successors_iterator->();
if($succ){
# if succ is at max depth and is not a goal node, set succ->fcost to infinity
if($succ->depth() >= $max_depth && !$succ->$goal_p() ){
$succ->{_f_cost} = $max_cost;
}
else{
# calling eval for comparison, and maintaining pathmax property
$succ->{_f_cost} = max($eval_func->($succ), $eval_func->($best));
my $descendant_index = $succ->{_descendant_index};
$best->{_descendant_fcosts}->[$descendant_index] = $succ->{_f_cost};
}
}
# determine if $best is completed, and if so backup values
if($best->is_completed()){
# remove from queue first, back up fvals, then insert back on queue.
# this way, it gets placed in its rightful place on the queue.
my $fval_before_backup = $best->{_f_cost};
# STEPS:
# 1) remove best and all antecedents from queue, but only if they are
# going to be altered by backing-up fvals. This is because
# 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;
}
}
};
my $antecedent = $best->{_antecedent};
my %was_on_queue;
my $i = 0;
# Now remove the offending nodes from queue, if any
if($best->need_fval_change()){
# remove best from the queue
$best = $$priority_queue->deepest_lowest_cost_leaf();
while($antecedent){
my $path_str = $str_function->($antecedent);
if($antecedent->is_on_queue() && $antecedent->need_fval_change()){
$was_on_queue{$i} = 1;
$$priority_queue->remove($antecedent, $cmp_func->($path_str));
}
$antecedent = $antecedent->{_antecedent};
$i++;
}
}
# Backup fvals
if($best->need_fval_change()){
$best->$backup_func();
}
# Put everything back on the queue
if($best->need_fval_change()){
$$priority_queue->insert($best);
my $antecedent = $best->{_antecedent};
my $i = 0;
while($antecedent){
if($was_on_queue{$i} && $antecedent->need_fval_change()){
# the antecedent needed fval change too.
$$priority_queue->insert($antecedent);
}
if($antecedent->need_fval_change()){
# set need_fval_change back to 0, so it will not be automatically seen as
# needing changed in the future. This is important, since we do not want
# to remove an element from the queue *unless* we need to change the fcost.
# This is because when we remove it from the queue and re-insert it, it
# loses its seniority in the queue (it becomes the newest node at its cost
# and depth) and will not be removed at the right time when searching for
# deepest_lowest_cost_leafs or shallowest_highest_cost_leafs.
$antecedent->{_need_fcost_change} = 0;
}
$antecedent = $antecedent->{_antecedent};
$i++;
}
# Again, set need_fval_change back to 0, so it will not be automatically
# seen as needing changed in the future.
$best->{_need_fcost_change} = 0;
}
}
#
# 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;
}
}
};
my $best_str = $str_function->($best);
# If best is not a root node
if($best->{_depth} != 0){
# descendant index is the unique index indicating which descendant
# this node is of its antecedent.
my $descendant_index = $best->{_descendant_index};
my $antecedent = $best->{_antecedent};
$$priority_queue->remove($best, $cmp_func->($best_str));
if($antecedent){
$antecedent->{_descendants_produced}->[$descendant_index] = 0;
}
}
}
# there are no more successors of $best
if(!$succ){
next;
}
my $antecedent;
my @antecedents_that_need_to_be_inserted;
# If the maximum number of states in the queue has been reached,
# we need to remove the shallowest-highest-cost leaf to make room
# for more nodes. That means we have to make sure that the antecedent
# produces this descendant again at some point in the future if needed.
if($num_states_in_queue > $max_states_in_queue){
my $shcl_obj = $$priority_queue->shallowest_highest_cost_leaf($best, $succ, $str_function);
if(!$shcl_obj){
croak "Error while pruning queue: shallowest-highest-cost-leaf was null\n";
}
$antecedent = $shcl_obj->{_antecedent};
if($antecedent){
my $antecedent_successors = \$antecedent->{_descendants_list};
$antecedent->remember_forgotten_nodes_fcost($shcl_obj);
$antecedent->{_forgotten_nodes_num} = $antecedent->{_forgotten_nodes_num} + 1;
my $descendant_index = $shcl_obj->{_descendant_index};
# record the index of this descendant in the forgotten_nodes list
$antecedent->{_forgotten_nodes_offsets}->{$descendant_index} = 1;
# flag the antecedent as not having this descendant in the queue
$antecedent->{_descendants_produced}->[$descendant_index] = 0;
$antecedent->{_descendant_fcosts}->[$descendant_index] = -1;
# flag the ancestor node as having deleted a descendant
$antecedent->descendants_deleted(1);
# update the number of descendants this node has in memory
$antecedent->{_num_successors_in_mem} = $antecedent->{_num_successors_in_mem} - 1;
# update the total number of nodes in the queue.
$num_states_in_queue--;
}
} # end if (num_states_on_queue > max_states)
# if there is a successor to $best, insert it in the priority queue.
if($succ){
$$priority_queue->insert($succ);
$best->{_num_successors_in_mem} = $best->{_num_successors_in_mem} + 1;
}
else{
croak "Error: no successor to insert\n";
}
}
}
continue {
$iteration++;
}
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){
return -1;
}
else{
return 1;
}
}
1;
__END__
# Below is stub documentation for your module. You'd better edit it!
=head1 NAME
AI::Pathfinding::SMAstar - Simplified Memory-bounded A* Search
=head1 SYNOPSIS
use AI::Pathfinding::SMAstar;
=head2 EXAMPLE
##################################################################
#
# This example uses a hypothetical object called FrontierObj, and
# shows the functions that the FrontierObj class must feature in
# order to perform a path-search in a solution space populated by
# FrontierObj objects.
#
##################################################################
my $smastar = AI::Pathfinding::SMAstar->new(
# evaluates f(n) = g(n) + h(n), returns a number
_state_eval_func => \&FrontierObj::evaluate,
# when called on a node, returns 1 if it is a goal
_state_goal_p_func => \&FrontierObj::goal_test,
# must return the number of successors of a node
_state_num_successors_func => \&FrontierObj::get_num_successors,
# must return *one* successor at a time
_state_successors_iterator => \&FrontierObj::get_successors_iterator,
# can be any suitable string representation
_state_get_data_func => \&FrontierObj::string_representation,
# gets called once per iteration, useful for showing algorithm progress
_show_prog_func => \&FrontierObj::progress_callback,
);
# You can start the search from multiple start-states.
# Add the initial states to the smastar object before starting the search.
foreach my $frontierObj (@start_states){
$smastar->add_start_state($frontierObj);
}
#
# Start the search. If successful, $frontierGoalPath will contain the
# goal path. The optimal path to the goal node will be encoded in the
# ancestry of the goal path. $frontierGoalPath->antecedent() contains
# the goal path's parent path, and so forth back to the start path, which
# contains only the start state.
#
# $frontierGoalPath->state() contains the goal FrontierObj itself.
#
my $frontierGoalPath = $smastar->start_search(
\&log_function, # returns a string used for logging progress
\&str_function, # returns a string used to *uniquely* identify a node
$max_states_in_queue, # indicate the maximum states allowed in memory
$MAX_COST, # indicate the maximum cost allowed in search
);
In the example above, a hypothetical object, C<FrontierObj>, is used to
represent a state, or I<node> in your search space. To use SMA* search to
find a shortest path from a starting node to a goal in your search space, you must
define what a I<node> is, in your search space (or I<point>, or I<state>).
A common example used for informed search methods, and one that is used in Russell's
original paper, is optimal puzzle solving, such as solving an 8 or 15-tile puzzle
lib/AI/Pathfinding/SMAstar.pm view on Meta::CPAN
approximation algorithms such as I<Simulated Annealing> can provide a
massive reduction in time and space requirements, while introducing a
tunable probability of producing a sub-optimal solution.
=head1 METHODS
=head2 new()
my $smastar = AI::Pathfinding::SMAstar->new();
Creates a new SMA* search object.
=head2 start_search()
my $frontierGoalObj = $smastar->start_search(
\&log_function, # returns a string used for logging progress
\&str_function, # returns a string used to *uniquely* identify a node
$max_states_in_queue, # indicate the maximum states allowed in memory
$MAX_COST, # indicate the maximum cost allowed in search
);
Initiates a memory-bounded search. When calling this function, pass a handle to
a function for recording current status( C<log_function> above- this can be
an empty subroutine if you don't care), a function that returns a *unique* string
representing a node in the search-space (this *cannot* be an empty subroutine), a
maximum number of expanded states to store in the queue, and a maximum cost
value (beyond which the search will cease).
=head2 state_eval_func()
$smastar->state_eval_func(\&FrontierObj::evaluate);
Set or get the handle to the function that returns the cost of the object
argument (node) in the search space.
=head2 state_goal_p_func()
$smastar->state_goal_p_func(\&FrontierObj::goal_test);
Set/get the handle to the goal predicate function. This is a function
that returns 1 if the argument object is a goal node, or 0 otherwise.
=head2 state_num_successors_func()
$smastar->state_num_successors_func(\&FrontierObj::get_num_successors);
Set/get the handle to the function that returns the number of successors
of this the object argument (node).
=head2 state_successors_iterator()
$smastar->state_successors_iterator(\&FrontierObj::get_successors_iterator);
Set/get the handle to the function that returns iterator that produces the
next successor of this node.
=head2 state_get_data_func()
$smastar->state_get_data_func(\&FrontierObj::string_representation);
Set/get the handle to the function that returns a string
representation of this node.
=head2 show_prog_func()
$smatar->show_prog_func(\&FrontierObj::progress_callback);
Sets/gets the callback function for displaying the progress of the search.
It can be an empty callback (sub{}) if you do not need this output.
=head2 DEPENDENCIES
Tree::AVL
Test::More
=head2 INCLUDED MODULES
AI::Pathfinding::SMAstar
AI::Pathfinding::SMAstar::Path
AI::Pathfinding::SMAstar::PriorityQueue
AI::Pathfinding::SMAstar::TreeOfQueues
=head2 EXPORT
None by default.
=head1 SEE ALSO
lib/AI/Pathfinding/SMAstar/AVLQueue.pm view on Meta::CPAN
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,
_obj_counts_tree => Tree::AVL->new(fcompare => \&AI::Pathfinding::SMAstar::PairObj::compare_keys_numeric,
fget_key => \&AI::Pathfinding::SMAstar::PairObj::key,
fget_data => \&AI::Pathfinding::SMAstar::PairObj::val),
@_, # Override previous attributes
};
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){
return(0);
}
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){
return(0);
}
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;
}
my $count = $found_obj->{_queue_counter};
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);
my $pairobj = AI::Pathfinding::SMAstar::PairObj->new(_key => $count,
_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("*");
my $iterator = $self->{_obj_counts_tree}->get_keys_iterator();
print "\n\niterator keys:\n";
while(defined(my $key = $iterator->())){
print "iterator key: $key\n";
}
}
1;
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){
$repeated_letters++;
}
}
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);
my @letters_seen = split('', $phrase);
my $collisions = 0;
foreach my $l (@letters){
foreach my $ls (@letters_seen){
if($l eq $ls){
$collisions++;
}
}
}
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);
my $sparseness = $length - $num_letters;
$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}){
return @{$memo_cache{$memo_key}};
}
else{
my @letters = split('', $word);
my @difference = ();
my %letters_hash = ();
my %letters_seen_hash = ();
my $intersect_num = 0;
my @intersection;
foreach my $element (@$sorted_letters_seen) { $letters_seen_hash{$element}++ }
foreach my $element (@letters) { $letters_hash{$element}++ }
foreach my $element (keys %letters_hash) {
if($letters_seen_hash{$element}){
push(@intersection, $element);
$intersect_num++;
}
else{
push(@difference, $element);
}
}
my @answer = ($intersect_num, @difference);
$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;
my @intersection;
foreach my $element (@$letters_seen) { $letters_seen_hash{$element}++ }
foreach my $element (@letters) { $letters_hash{$element}++ }
foreach my $element (keys %letters_hash) {
if($letters_seen_hash{$element}){
push(@intersection, $element);
$intersect_num++;
}
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){
#print $spaces . "DING DING DING. cache hit!\n";
return @$cached_vals;
}
else{
my @substr_cands = get_substrs_memo($word, $dictionary_rev);
my @superstr_cands = $dictionary_rev->acc_lookup_memo($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.
$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)
{
return;
}
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){
#print $spaces . "DING DING DING. cache hit!\n";
return @$cached_vals;
}
else{
for(my $i = 1; $i < length($word); $i++){
push(@words, substr($word, 0, $i));
}
foreach my $substring (@words){
#print "looking for matches on: \"$substring\"\n";
my $cand = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $substring
);
my $match_word = $dictionary->lookup($cand, \&AI::Pathfinding::SMAstar::Examples::WordObj::compare);
if($match_word){
# print "FOUND A MATCH: $match_word\n";
push(@matches, $match_word);
}
}
#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));
}
foreach my $substring (@words){
#print "looking for matches on: \"$substring\"\n";
my $cand = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $substring
);
my $match_word = $dictionary->lookup($cand, \&AI::Pathfinding::SMAstar::Examples::WordObj::compare);
if($match_word){
# print "FOUND A MATCH: $match_word\n";
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)
{
chomp($word);
my $sparsity = get_word_sparsity($word);
if($sparsity <= $max_score){
$word_objs[$i] = AI::Pathfinding::SMAstar::Examples::WordObj->new(
_word => $word,
);
$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)
{
chomp($word);
my $rev_word = reverse($word);
my $sparsity = get_word_sparsity($word);
if($sparsity <= $max_score){
$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}){
return $memo_cache{$first_half};
}
else{
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;
close(READF);
my @filtered_words;
my $i = 0;
foreach my $word (@lines)
{
chomp($word);
my $sparsity = get_word_sparsity($word);
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;
close(READF);
my @filtered_words;
my $i = 0;
foreach my $word (@lines)
{
chomp($word);
my $sparsity = get_word_sparsity($word);
if($sparsity <= $max_score){
my $rev_word = reverse($word);
$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 = "|";
}
elsif($state == 3){
$spinny_thing = "/";
}
my ($progress) = @_;
my $stars = '*' x int($progress*10);
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)
# printf "\e[%d;%dH", $R, $C; # Put cursor at row $R, column $C (good for "drawing")
#print "\e[H\e[J"; #clears the entire screen
printf "\e[%d;%dH", $LINES-1, 1; # Put cursor at row $R, column $C (good for "drawing")
print "\e[J"; #clears to end of screen
if($num_states > $max_nodes_in_mem){
$max_nodes_in_mem = $num_states;
}
print "\riteration: $iteration, num_states_in_memory: $num_states, max_states_in_mem: $max_nodes_in_mem\n";
printf "\e[%d;%dH", $LINES, 1; # Put cursor at row $R, column $C (good for "drawing")
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
# Date : June 2008
#
#
package AI::Pathfinding::SMAstar::Examples::Phrase;
use Tree::AVL;
use AI::Pathfinding::SMAstar::Examples::PalUtils;
use strict;
BEGIN {
use Exporter ();
@AI::Pathfinding::SMAstar::Examples::Phrase::ISA = qw(Exporter);
@AI::Pathfinding::SMAstar::Examples::Phrase::EXPORT = qw();
@AI::Pathfinding::SMAstar::Examples::Phrase::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;
##################################################
## 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
_predecessor => undef,
_dir => 0,
_repeated_pal_hash_ref => {},
_match_remainder_left => undef,
_match_remainder_right => undef,
_letters_seen => undef, # letters seen, up to/including antecedent
_cost => undef, # cost used for heuristic search
_cost_so_far => undef,
_num_chars_so_far => undef, # cummulative cost used for heuristic
_num_new_chars => undef,
_no_match_remainder => undef, # flag specifying whether there was a remainder
_phrase => undef,
_depth => 0,
_f_cost => 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 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){
return 0;
}
return 1;
}
#----------------------------------------------------------------------------
# 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)){
return $fcost;
}
my $word = $self->{_start_word};
my $cost = $self->{_cost};
my $cost_so_far = $self->{_cost_so_far};
my $num_new_chars = $self->{_num_new_chars};
my $num_chars_so_far = $self->{_num_chars_so_far};
my $phrase = defined($self->{_phrase}) ? $self->{_phrase} : "";
my $len_phrase = length($phrase);
my $phrase_num_chars = AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_word($phrase);
my $ratio = 0;
if($phrase_num_chars){
$ratio = $len_phrase/$phrase_num_chars;
}
#my $total_cost = $cost_so_far + $cost;
my $total_cost = $cost_so_far + $cost + $ratio;
#my $total_cost = 0; # greedy search (best-first search)
#my $distance_from_goal = 0; # branch and bound search. optimistic/admissible.
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)){
return 1;
}
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};
my $repeated_pal_hash_ref = $phrase_obj->{_repeated_pal_hash_ref};
my $letters_seen = $phrase_obj->{_letters_seen};
my $cost = $phrase_obj->{_cost};
my $cost_so_far = $phrase_obj->{_cost_so_far};
my $num_chars_so_far = $phrase_obj->{_num_chars_so_far};
my $no_match_remainder = $phrase_obj->{_no_match_remainder};
my $depth = $phrase_obj->{_depth};
my $direction = $phrase_obj->{_dir};
my $word = $phrase_obj->{_start_word};
my $whole_word = $phrase_obj->{_cand};
my $len_whole_word = defined($whole_word) ? length($whole_word) : 0;
my $rev_word = reverse($word);
my $len_word = length($word);
my @cands;
my @descendants;
if($direction == 0){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_left($word, $dictionary, $dictionary_rev);
}
elsif($direction == 1){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_right($word, $dictionary, $dictionary_rev);
}
#----------------Letters Seen-----------------------------------------------
my @sorted_letters_seen = sort(@$letters_seen);
# how much does this word collide with the letters seen so far, and what are the new letters?
my ($word_intersect, @differences) = AI::Pathfinding::SMAstar::Examples::PalUtils::word_collision($word, \@sorted_letters_seen);
# store the difference in new letters_seen value.
push(@sorted_letters_seen, @differences);
my $new_num_chars_so_far = @sorted_letters_seen;
#-----------------------------------------------------------
my @words_to_make_phrases;
my $stored_c;
return sub{
LABEL1:
# this is a continuation of the second case below, where there were no
# match-remainders for the phrase-so-far, i.e. the palindrome has a space
# in the middle with mirrored phrases on each side. 'cat tac' for example.
my $next_word = shift(@words_to_make_phrases);
if($next_word){
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
goto LABEL1;
#next; #skip this word, we are already looking at it
}
#----------------Compute the Cost-------------------------------------------
my $len_w = length($w);
my $collisions_per_length = AI::Pathfinding::SMAstar::Examples::PalUtils::collisions_per_length($w, $phrase_obj->{_phrase});
my $sparsity = AI::Pathfinding::SMAstar::Examples::PalUtils::get_word_sparsity_memo($w);
my $num_chars = AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_word_memo($w);
my ($word_intersect, @differences) = AI::Pathfinding::SMAstar::Examples::PalUtils::word_collision($w,
\@sorted_letters_seen);
my $num_new_chars = $num_chars - $word_intersect;
#my $newcost = $collisions_per_length + $sparsity;
my $newcost = $collisions_per_length + $len_w;
my $new_cost_so_far = $cost + $cost_so_far;
#---------------------------------------------------------------------------
my $new_phrase = AI::Pathfinding::SMAstar::Examples::Phrase->new(
_word_list => $words,
#_words_w_cands_list => \@words_to_make_phrases,
_words_w_cands_list => $words_w_cands,
_dictionary => $dictionary,
_dictionary_rev => $dictionary_rev,
_start_word => $w,
_cand => $stored_c,
_word => $w,
_predecessor => $phrase_obj,
_dir => 0,
_repeated_pal_hash_ref => $repeated_pal_hash_ref,
_letters_seen => \@sorted_letters_seen,
_cost => $newcost,
_cost_so_far => $new_cost_so_far,
_num_chars_so_far => $new_num_chars_so_far,
_num_new_chars => $num_new_chars,
_no_match_remainder => 1,
_depth => $depth+1,
);
#print "returning new phrase from first cond.\n";
$new_phrase->{_phrase} = $new_phrase->roll_up_phrase();
return $new_phrase;
}
else{
my $c = shift(@cands);
if(!$c){
return;
}
# ------------- filter for repeated palcands for a particular word------
# ----------------------------------------------------------------------
# This will avoid many repeated patterns among palindromes to trim down the
# number redundant palindromes generated.
#
my $letters_seen_str = join("", @{$phrase_obj->{_letters_seen}});
if($letters_seen_str){
my $repeated_pal_hash_key;
$repeated_pal_hash_key = $word . "^" . $c . "^" . $letters_seen_str;
#print "\n\nrepeated_pal_hash_key: $repeated_pal_hash_key\n";
if(my $hash_val = $repeated_pal_hash_ref->{$repeated_pal_hash_key}){
# skip because '$word' <--> '$p' pattern has already appeared in a previous palindrome.
if($hash_val != $depth){
goto LABEL1;
# next; # skip
}
}
else{
#flag this candidate as already having been tested (below).
$repeated_pal_hash_ref->{$repeated_pal_hash_key} = $depth;
}
}
#--------------------------------------------------------------------------
#--------------------------------------------------------------------------
my $len_c = length($c);
my $rev_c = reverse($c);
my $word_remainder;
if($len_c < $len_word){
$word_remainder = $c;
}
elsif($len_c > $len_word){
$word_remainder = $word;
}
my $rev_word_remainder = reverse($word);
my $num_cands = @cands;
my $match_remainder;
my $len_match_remainder;
my $newcost;
my $new_cost_so_far;
my $num_new_chars;
my $new_direction;
if($direction == 0){
if($len_c < $len_word){
$match_remainder = AI::Pathfinding::SMAstar::Examples::PalUtils::match_remainder($word, $rev_c);
$new_direction = 0;
}
elsif($len_c > $len_word){
$match_remainder = AI::Pathfinding::SMAstar::Examples::PalUtils::match_remainder($rev_c, $word);
$match_remainder = reverse($match_remainder);
$new_direction = 1;
}
}
elsif($direction == 1){
if($len_c < $len_word){
$match_remainder = AI::Pathfinding::SMAstar::Examples::PalUtils::match_remainder($rev_word, $c);
$match_remainder = reverse($match_remainder);
$new_direction = 1;
}
elsif($len_c > $len_word){
$match_remainder = AI::Pathfinding::SMAstar::Examples::PalUtils::match_remainder($c, $rev_word);
$new_direction = 0;
}
}
$len_match_remainder = defined($match_remainder) ? length($match_remainder) : 0;
#----------------Compute the Cost-------------------------------------------
if($len_c < $len_word){
$num_new_chars = 0;
$newcost = 0; # new candidate is a (reversed) substring of word
$new_cost_so_far = $cost + $cost_so_far;
}
elsif($len_c > $len_word){
#if($len_c != $len_word){
my $collisions_per_length = AI::Pathfinding::SMAstar::Examples::PalUtils::collisions_per_length($match_remainder, $phrase_obj->{_phrase});
my $num_chars = AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_word_memo($match_remainder);
my $sparsity = AI::Pathfinding::SMAstar::Examples::PalUtils::get_word_sparsity_memo($match_remainder);
my ($word_intersect, @differences) = AI::Pathfinding::SMAstar::Examples::PalUtils::word_collision_memo($match_remainder,
\@sorted_letters_seen);
$num_new_chars = $num_chars - $word_intersect;
#$newcost = $sparsity + $collisions_per_length;
$newcost = $collisions_per_length + $len_match_remainder;
$new_cost_so_far = $cost + $cost_so_far;
}
#---------------------------------------------------------------------------
if($match_remainder){ # there is a length difference between the candidate and this word.
my $new_phrase = AI::Pathfinding::SMAstar::Examples::Phrase->new(
_word_list => $words,
_words_w_cands_list => $words_w_cands,
_dictionary => $dictionary,
_dictionary_rev => $dictionary_rev,
_start_word => $match_remainder,
_cand => $c,
_word => $whole_word,
_predecessor => $phrase_obj,
_dir => $new_direction,
_repeated_pal_hash_ref => $repeated_pal_hash_ref,
_letters_seen => \@sorted_letters_seen,
_cost => $newcost,
_cost_so_far => $new_cost_so_far,
_num_chars_so_far => $new_num_chars_so_far,
_num_new_chars => $num_new_chars,
_depth => $depth+1,
);
#print "returning new phrase from second cond.\n";
$new_phrase->{_phrase} = $new_phrase->roll_up_phrase();
return $new_phrase;
}
else{
#
# There is no match_remainder, so this candidate is the reverse
# of $word, or the phrase built so far is an "even" palindrome,
# i.e. it has a word boundary (space) in the middle.
#
#
# This is a special case since there is no match remainder.
# Because there is no remainder to create new phrase obj from, this
# section goes through the whole word list and creates phrase objects
# for each new word. The number of new characters offered by each
# word is recorded to help with guided search.
#
# Update: this case now only goes through the word list for which there
# are cands.
@words_to_make_phrases = @$words_w_cands;
#@words_to_make_phrases = @$words;
$stored_c = $c;
my $next_word = shift(@words_to_make_phrases);
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
goto LABEL1;
#next; #skip this word, we are already looking at it
}
#----------------Compute the Cost-------------------------------------------
my $len_w = length($w);
my $collisions_per_length = AI::Pathfinding::SMAstar::Examples::PalUtils::collisions_per_length($w, $phrase_obj->{_phrase});
my $sparsity = AI::Pathfinding::SMAstar::Examples::PalUtils::get_word_sparsity_memo($w);
my $num_chars = AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_word_memo($w);
my ($word_intersect, @differences) = AI::Pathfinding::SMAstar::Examples::PalUtils::word_collision_memo($w,
\@sorted_letters_seen);
my $num_new_chars = $num_chars - $word_intersect;
#my $newcost = $collisions_per_length + $sparsity;
my $newcost = $collisions_per_length + $len_w;
my $new_cost_so_far = $cost + $cost_so_far;
#---------------------------------------------------------------------------
my $new_phrase = AI::Pathfinding::SMAstar::Examples::Phrase->new(
_word_list => $words,
_words_w_cands_list => $words_w_cands,
_dictionary => $dictionary,
_dictionary_rev => $dictionary_rev,
_start_word => $w,
_cand => $c,
_word => $w,
_predecessor => $phrase_obj,
_dir => 0,
_repeated_pal_hash_ref => $repeated_pal_hash_ref,
_letters_seen => \@sorted_letters_seen,
_cost => $newcost,
_cost_so_far => $new_cost_so_far,
_num_chars_so_far => $new_num_chars_so_far,
_num_new_chars => $num_new_chars,
_no_match_remainder => 1,
_depth => $depth+1,
);
#print "returning new phrase from third cond.\n";
$new_phrase->{_phrase} = $new_phrase->roll_up_phrase();
return $new_phrase;
}
}
}
}
#-----------------------------------------------------------------------------
# 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++;
}
return $num_successors
}
#-----------------------------------------------------------------------------
# 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};
my $repeated_pal_hash_ref = $phrase_obj->{_repeated_pal_hash_ref};
my $letters_seen = $phrase_obj->{_letters_seen};
my $cost = $phrase_obj->{_cost};
my $cost_so_far = $phrase_obj->{_cost_so_far};
my $num_chars_so_far = $phrase_obj->{_num_chars_so_far};
my $no_match_remainder = $phrase_obj->{_no_match_remainder};
my $depth = $phrase_obj->{_depth};
my $direction = $phrase_obj->{_dir};
my $word = $phrase_obj->{_start_word};
my $whole_word = $phrase_obj->{_cand};
my $len_word = length($word);
my @cands;
my @descendants;
if($direction == 0){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_left($word, $dictionary, $dictionary_rev);
}
elsif($direction == 1){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_right($word, $dictionary, $dictionary_rev);
}
my @words_to_make_phrases;
my $stored_c;
my $num_successors = 0;
while(1){
# this is a continuation of the second case below, where there were no
# match-remainders for the phrase-so-far, i.e. the palindrome has a space
# in the middle with mirrored phrases on each side. 'cat tac' for example.
my $next_word = shift(@words_to_make_phrases);
if($next_word){
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
next; #skip this word, we are already looking at it
}
$num_successors++;
}
else{
my $c = shift(@cands);
if(!$c){
return $num_successors;
}
# ------------- filter for repeated palcands for a particular word------
# ----------------------------------------------------------------------
# This will avoid many repeated patterns among palindromes to trim down the
# number redundant palindromes generated.
#
my $letters_seen_str = join("", @{$phrase_obj->{_letters_seen}});
if($letters_seen_str){
my $repeated_pal_hash_key;
$repeated_pal_hash_key = $word . "^" . $c . "^" . $letters_seen_str;
#print "\n\nrepeated_pal_hash_key: $repeated_pal_hash_key\n";
if(my $hash_val = $repeated_pal_hash_ref->{$repeated_pal_hash_key}){
# skip because '$word' <--> '$p' pattern has already appeared in a previous palindrome.
if($hash_val != $depth){
next; #skip
}
}
else{
#flag this candidate as already having been tested (below).
$repeated_pal_hash_ref->{$repeated_pal_hash_key} = $depth;
}
}
#--------------------------------------------------------------------------
#--------------------------------------------------------------------------
my $len_c = length($c);
my $rev_c = reverse($c);
my $word_remainder;
if($len_c < $len_word){
$word_remainder = $c;
}
elsif($len_c > $len_word){
$word_remainder = $word;
}
my $rev_word_remainder = reverse($word);
my $num_cands = @cands;
my $match_remainder;
my $len_match_remainder;
if($len_c != $len_word){
$match_remainder = 1;
}
if($match_remainder){ # there is a length difference between the candidate and this word.
$num_successors++;
}
else{
#
# There is no match_remainder, so this candidate is the reverse
# of $word, or the phrase built so far is an "even" palindrome,
# i.e. it has a word boundary (space) in the middle.
#
#
# This is a special case since there is no match remainder.
# Because there is no remainder to create new phrase obj from, this
# section goes through the whole word list and creates phrase objects
# for each new word. The number of new characters offered by each
# word is recorded to help with guided search.
#
# Update: this case now only goes through the word list for which there
# are cands.
@words_to_make_phrases = @$words_w_cands;
#@words_to_make_phrases = @$words;
$stored_c = $c;
my $next_word = shift(@words_to_make_phrases);
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
next; #skip this word, we are already looking at it
}
$num_successors++;
}
}
}
return $num_successors;
}
#-----------------------------------------------------------------------------
# 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};
my $repeated_pal_hash_ref = $phrase_obj->{_repeated_pal_hash_ref};
my $letters_seen = $phrase_obj->{_letters_seen};
my $cost = $phrase_obj->{_cost};
my $cost_so_far = $phrase_obj->{_cost_so_far};
my $num_chars_so_far = $phrase_obj->{_num_chars_so_far};
my $no_match_remainder = $phrase_obj->{_no_match_remainder};
my $depth = $phrase_obj->{_depth};
my $direction = $phrase_obj->{_dir};
my $word = $phrase_obj->{_start_word};
my $whole_word = $phrase_obj->{_cand};
my $len_word = length($word);
my @cands;
my @descendants;
if($direction == 0){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_left($word, $dictionary, $dictionary_rev);
}
elsif($direction == 1){
@cands = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_right($word, $dictionary, $dictionary_rev);
}
my @words_to_make_phrases;
my $stored_c;
return sub{
LABEL:
# this is a continuation of the second case below, where there were no
# match-remainders for the phrase-so-far, i.e. the palindrome has a space
# in the middle with mirrored phrases on each side. 'cat tac' for example.
my $next_word = shift(@words_to_make_phrases);
if($next_word){
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
goto LABEL;
#next; #skip this word, we are already looking at it
}
return 1;
}
else{
my $c = shift(@cands);
if(!$c){
return;
}
# ------------- filter for repeated palcands for a particular word------
# ----------------------------------------------------------------------
# This will avoid many repeated patterns among palindromes to trim down the
# number redundant palindromes generated.
#
my $letters_seen_str = join("", @{$phrase_obj->{_letters_seen}});
if($letters_seen_str){
my $repeated_pal_hash_key;
$repeated_pal_hash_key = $word . "^" . $c . "^" . $letters_seen_str;
#print "\n\nrepeated_pal_hash_key: $repeated_pal_hash_key\n";
if(my $hash_val = $repeated_pal_hash_ref->{$repeated_pal_hash_key}){
# skip because '$word' <--> '$p' pattern has already appeared in a previous palindrome.
if($hash_val != $depth){
goto LABEL;
# next; #skip
}
}
else{
#flag this candidate as already having been tested (below).
$repeated_pal_hash_ref->{$repeated_pal_hash_key} = $depth;
}
}
#--------------------------------------------------------------------------
#--------------------------------------------------------------------------
my $len_c = length($c);
my $rev_c = reverse($c);
my $word_remainder;
if($len_c < $len_word){
$word_remainder = $c;
}
elsif($len_c > $len_word){
$word_remainder = $word;
}
my $rev_word_remainder = reverse($word);
my $num_cands = @cands;
my $match_remainder;
my $len_match_remainder;
if($len_c != $len_word){
$match_remainder = 1;
}
if($match_remainder){ # there is a length difference between the candidate and this word.
return 1;
}
else{
#
# There is no match_remainder, so this candidate is the reverse
# of $word, or the phrase built so far is an "even" palindrome,
# i.e. it has a word boundary (space) in the middle.
#
#
# This is a special case since there is no match remainder.
# Because there is no remainder to create new phrase obj from, this
# section goes through the whole word list and creates phrase objects
# for each new word. The number of new characters offered by each
# word is recorded to help with guided search.
#
# Update: this case now only goes through the word list for which there
# are cands.
@words_to_make_phrases = @$words_w_cands;
#@words_to_make_phrases = @$words;
$stored_c = $c;
my $next_word = shift(@words_to_make_phrases);
my $w = $next_word;
my $repeated_word_p = 0;
my $antecedent = $phrase_obj->{_predecessor};
my $antecedent_dir = $antecedent->{_dir};
while($antecedent){
if(defined($antecedent->{_word}) && $w eq $antecedent->{_word} && $antecedent_dir == 0){
$repeated_word_p = 1;
last;
}
$antecedent = $antecedent->{_predecessor};
if($antecedent){
$antecedent_dir = $antecedent->{_dir};
}
}
if($repeated_word_p || $w eq $word){
goto LABEL;
#next; #skip this word, we are already looking at it
}
return 1;
}
}
}
}
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.
return $pobj->{_start_word};
}
else{
# if depth is 0, that means this is a top-level call.
# otherwise this is the nth iteration within this while loop.
# if this is a top-level call and _phrase is already defined,
# just return _phrase.
if(defined($pobj->{_phrase}) && !$depth){
return $pobj->{_phrase};
}
my $direction = $pobj->{_dir};
my $antecedent = $pobj->{_predecessor};
my $antecedent_predecessor;
my $no_match_remainder = $pobj->{_no_match_remainder};
my $ant_direction = 0;
my $ant_cand;
if($antecedent){
$antecedent_predecessor = $antecedent->{_predecessor};
$ant_direction = $antecedent->{_dir};
$ant_cand = $antecedent->{_cand};
}
my $word = defined($pobj->{_word}) ? $pobj->{_word} : "";
my $startword = defined($pobj->{_start_word}) ? $pobj->{_start_word} : "";
my $cand = defined($pobj->{_cand}) ? $pobj->{_cand} : "";
if(!$phrase){
if($direction == 0){
$phrase = $cand;
}
elsif($direction == 1){
$phrase = $cand;
}
}
else{
if($direction == 0){
if($ant_direction == 0){
#**** special case for root node descendant***
if(!$antecedent_predecessor){ # antecedent is root node.
if($word){
$phrase = $word . " " . $phrase . " " . $cand;
}
else{
$phrase = $phrase . " " . $cand;
}
}
else{
if($no_match_remainder){ # handle the case where there was no match remainder
$phrase = $word . " " . $phrase . " " . $cand;
}
else{
$phrase = "" . $phrase . " " . $cand;
}
}
}
elsif($ant_direction == 1){
if($no_match_remainder){ # handle the case where there was no match remainder
$phrase = $cand . " " . $word . " " . $phrase . "";
}
else{
$phrase = $cand . " " . $phrase . "";
}
}
}
elsif($direction == 1){
if($ant_direction == 0){
$phrase = "" . $phrase . " " . $cand;
}
elsif($ant_direction == 1){
$phrase = $cand . " " . $phrase . "";
}
}
}
}
$pobj = $pobj->{_predecessor};
$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};
$ant_phrase = $antecedent->{_phrase} ? $antecedent->{_phrase} : $antecedent->{_start_word};
}
else{
$antecedent->{_phrase} = "none";
}
# print " $line_num, destroying phrase object $self, '" . $self->{_start_word} . ", " . $self->{_phrase} .
# "', parent is $antecedent: '" . $ant_phrase . "' \n";
# if($line_num != 0){ # if not final sweep at program exit
# print " caller is: $pkg, $filename, $line_num\n";
# }
if($line_num == 0){ # line_num is zero
$d++;
# print "\$d : $d\n";
}
#${$self->{_predecessor}} = 0;
#${$self->{_descendants_list}} = 0;
delete $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;
}
return 1;
}
# 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);
}
elsif($arg_word gt $word){
return(-1);
}
elsif($arg_word lt $word){
return(1);
}
}
}
# 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);
}
elsif($arg_word gt $word){
return(-1);
}
elsif($arg_word lt $word){
return(1);
}
}
}
1; # so the require or use succeeds
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;
}
return 1;
}
# 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
# Author: matthias beebe
# Date : June 2008
#
#
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};
$antecedent->{_descendant_fcosts}->[$descendant_index] = $least_fcost;
}
}
else{
# not changing fcost. current fcost: $self->{_f_cost}, least_fcost: $least_fcost
last;
}
$self = $self->{_antecedent};
} #end while
return;
}
#
# 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){
return 1;
}
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;
}
#-----------------------------------------------------------------------------
# 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
# this once.
if(!defined($self->{_num_successors})){
$num_successors = $self->get_num_successors();
$self->{_num_successors} = $num_successors;
$#{$self->{_descendants_produced}} = $num_successors;
$#{$self->{_descendant_fcosts}} = $num_successors;
$#{$self->{_forgotten_node_fcosts}} = $num_successors;
for (my $i = 0; $i <= $num_successors; $i++){
$self->{_descendants_produced}->[$i] = 0;
$self->{_descendant_fcosts}->[$i] = -1;
$self->{_forgotten_node_fcosts}->[$i] = -1;
}
}
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(
_state => $next_state,
_eval_func => $self->{_eval_func},
_goal_p_func => $self->{_goal_p_func},
_get_data_func => $self->{_get_data_func},
_num_successors_func => $self->{_num_successors_func},
_successors_iterator => $self->{_successors_iterator},
_antecedent => $self,
_depth => $depth + 1,
);
my $start_word = $next_descendant->{_state}->{_start_word};
my $phrase = $next_descendant->{_state}->{_phrase};
my $already_produced_p = $self->{_descendants_produced}->[$i] || ($self->{_descendant_fcosts}->[$i] != -1);
if($already_produced_p){
# have already produced this descendant
$descendants_found++;
# found descendant in tree\n";
if($i == $num_successors - 1 && $descendants_deleted){
# !!! resetting iterator index. descendants have been deleted. clearing forgotten_fcosts on next expansion.
$iterator = $self->get_successors_iterator();
$self->{_iterator_index} = 0;
$i = 0;
# setting completed to 1 (true)
$self->is_completed(1);
next;
}
else{
$i++;
}
if($descendants_found == $num_successors){
# setting completed to 1.
$self->is_completed(1);
}
$next_descendant = undef; # found this one in list, so undef next descendant.
}
else{
# did not find descendant in descendant's list
if($i < $self->{_iterator_index} && $self->{_forgotten_nodes_num} != 0){
# did not find descendant in list, but may have already produced this
# descendant since this node was created.
$i++;
$descendants_deleted++;
next;
}
# did not find descendant in list, adding now.
$next_descendant->{_descendant_index} = $i;
$self->{_descendants_produced}->[$i] = 1;
# new descendant's index is $i
$self->{_iterator_index} = $i + 1;
if($self->{_iterator_index} == $self->{_num_successors}){
$iterator = $self->get_successors_iterator();
$self->{_iterator_index} = 0;
$i = 0;
# node is completed, setting completed to 1\n";
$self->is_completed(1);
}
# break out of while() loop
last;
}
}
if($i >= $num_successors - 1 && $descendants_deleted && $self->depth() == 0){
# root node. going to reset iterator index. descendants have been deleted. Also, will be
# clearing out forgotten_descendants fcost list, since those descendants will be re-generated anyway.
$iterator = $self->get_successors_iterator();
$self->{_iterator_index} = 0;
$i = 0;
# setting completed to 1
$self->is_completed(1);
}
if($next_descendant){
if($self->{_forgotten_node_fcosts}->[$next_descendant->{_descendant_index}] != -1){
# erase the index of this node in the forgotten_nodes list
$self->{_forgotten_node_fcosts}->[$next_descendant->{_descendant_index}] = -1;
# decrement the number of forgotten nodes
$self->{_forgotten_nodes_num} = $self->{_forgotten_nodes_num} - 1;
delete $self->{_forgotten_nodes_offsets}->{$next_descendant->{_descendant_index}};
}
}
else{
# 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::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;
my $depth_keys_iterator;
while(1){
while($least_depth == 0){
$avltree = $cost_hash_ref->{$highest_cost_key}; #tree with highest cost
# get the deepest queue in the tree
# so we can use it to step backward to the smallest non-zero
# depth in the following loop
my $queue_at_largest_depth = $$avltree->largest();
$least_depth = $queue_at_largest_depth->key();
$depth_keys_iterator = $$avltree->get_keys_iterator();
# get lowest non-zero key of tree (smallest non-zero depth)
while (defined(my $key = $depth_keys_iterator->())){
#########################################################################
#
# Does this need to be a non-zero depth element? yes. (example: test68.lst)
#
#########################################################################
if($key != 0){
$least_depth = $key;
last;
}
}
# if no non-zero depths, find the next highest key and loop back
my $next_highest_cost_key;
if($least_depth == 0){
$next_highest_cost_key = next_largest_element(\@cost_keys, $highest_cost_key);
$highest_cost_key = $next_highest_cost_key;
if(!$highest_cost_key){
print "no highest_cost_key found\n";
exit;
}
}
else{ # least depth is non-zero, so it's good
last;
}
} # Now have a good highest_cost_key, with a tree that has a good non-zero key queue somewhere in it.
my $queue = $$avltree->get_queue($least_depth); # get the queue at least_depth
my $queue_keys_iterator = $queue->get_keys_iterator();
my $queue_key = $queue_keys_iterator->(); # burn the first value from the iterator since we're getting first object on next line.
$obj = $$avltree->oldest_at($least_depth); # get the shallowest one that is not at zero depth
my $i = 1;
while($compare_func->($obj, $best) || $compare_func->($obj, $succ) || $obj->has_descendants_in_memory()){
if($queue_key = $queue_keys_iterator->()){
$obj = $queue->lookup_by_key($queue_key);
}
else{
# need a new least_depth. check if there are any more queues with non-zero depth in this tree.
# if not, need a new highest_cost_key.
$obj = undef;
my $next_smallest = $depth_keys_iterator->();
if(!defined($next_smallest)){
last;
}
else{
$least_depth = $next_smallest;
$queue = $$avltree->get_queue($least_depth); # get the queue at least_depth
$queue_keys_iterator = $queue->get_keys_iterator();
$queue_key = $queue_keys_iterator->(); # burn the first value from the iterator
$obj = $$avltree->oldest_at($least_depth); # get the shallowest one that is not at zero depth
$i = 1;
next;
}
}
$i++;
} # end while($compare_func->($obj, $best) || $compare_func->($obj, $succ) || $obj->has_descendants_in_memory())
# done loop on last highest_cost_key. if obj is not found, get another highest_cost_key, and loop back again.
if(!$obj){
$least_depth = 0;
$highest_cost_key = next_largest_element(\@cost_keys, $highest_cost_key);
}
else{
last;
}
} # end while(1)
my $obj_str = $str_function->($obj);
$$avltree->remove($obj, $cmp_func->($obj_str));
if($obj){
$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);
if($$avltree->is_empty()){
delete $cost_hash_ref->{$highest_cost_key};
$cost_min_max_tree->remove($highest_cost_key);
}
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++)
{
if($$array[$i] < $val && $largest < $$array[$i]){
$largest = $$array[$i];
}
}
if($largest != -1){
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;
my $smallest = $max;
for($i = 0; $i < @$array; $i++)
{
if($$array[$i] > $val && $$array[$i] < $smallest){
$smallest = $$array[$i];
}
}
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);
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);
if(!$found_queue){
# print "TreeOfQueues::remove: did not find queue with key $key\n";
# $self->{_avl_tree}->print();
}
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();
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();
if($queue->is_empty()){
$$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();
if($queue->is_empty()){
$$avltree->remove($queue);
}
return $obj;
}
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;
}
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();
foreach my $queue (@queue_list){
#print "queue is $queue\n";
my $queue_key = $queue->key();
#print "queue key: $queue_key\n";
my @objlist = $queue->get_list();
if(!@objlist){
print "queue at key $queue_key is empty\n";
}
print "queue at key $queue_key:\n";
foreach my $obj (@objlist){
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(">>>");
my @queue_list = $self->{_avl_tree}->get_list();
foreach my $queue (@queue_list){
my $queue_key = $queue->key();
my @objlist = $queue->get_list();
#print "get_list: size of queue at key: $queue_key is: " . @objlist . "\n";
push(@objs, @objlist);
}
return @objs;
}
1;
t/AI-Pathfinding-SMAstar.t view on Meta::CPAN
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 9;
BEGIN { use_ok('AI::Pathfinding::SMAstar');
use_ok('Tree::AVL');
use_ok('AI::Pathfinding::SMAstar::Examples::PalUtils');
use_ok('AI::Pathfinding::SMAstar::Examples::WordObj');
use_ok('AI::Pathfinding::SMAstar::Examples::Phrase');
};
#########################
# Insert your test code below, the Test::More module is use()ed here so read
# its man page ( perldoc Test::More ) for help writing this test script.
my $dictionary_file;
my $min_letters;
my $caching;
t/AI-Pathfinding-SMAstar.t view on Meta::CPAN
#my $collisions_per_length = PalUtils::collisions_per_length("ocid", "abo gad abalones rot abdicators enol aba dagoba");
#print "collisions: $collisions_per_length\n";
#exit;
$dictionary_file = 't/test8.lst';
$min_letters = 4;
$sparsity = 2;
$max_states_in_queue = 4;
diag("\ncreating AVL trees");
# create trees of WordObj objects, so that we can use
# WordObj::compare_up_to(), the 'relaxed' comparison function
my $avltree = Tree::AVL->new(
fcompare => \&AI::Pathfinding::SMAstar::Examples::WordObj::compare,
fget_key => \&AI::Pathfinding::SMAstar::Examples::WordObj::word,
fget_data => \&AI::Pathfinding::SMAstar::Examples::WordObj::word,
);
my $avltree_rev = Tree::AVL->new(
fcompare => \&AI::Pathfinding::SMAstar::Examples::WordObj::compare,
fget_key => \&AI::Pathfinding::SMAstar::Examples::WordObj::word,
fget_data => \&AI::Pathfinding::SMAstar::Examples::WordObj::word,
);
print STDERR "-" x 80 . "\n";
print STDERR "-" x 80 . "\n";
diag("reading dictionary '$dictionary_file'");
eval{
($num_words, @words) = AI::Pathfinding::SMAstar::Examples::PalUtils::read_dictionary_filter_by_density($dictionary_file, $sparsity);
};
is( $@, '', '$@ is not set after object insert' );
diag("loaded words: '$num_words'");
isnt( $num_words, undef, 'num_words is $num_words');
%letter_freq = AI::Pathfinding::SMAstar::Examples::PalUtils::find_letter_frequencies(@words);
foreach my $w (@words){
my $length = length($w);
if($length > $max_word_length){
$max_word_length = $length;
}
}
$num_words_filtered = @words;
diag("$num_words words in the currently loaded dictionary. Minimum letters specified = $min_letters");
diag("$num_words_filtered words that meet the initial sparsity constraint max_sparsity = $sparsity.");
if(!@words){
print STDERR "no words to process. exiting\n";
exit;
}
@word_objs = AI::Pathfinding::SMAstar::Examples::PalUtils::process_words_by_density(\@words, $sparsity);
@rev_word_objs = AI::Pathfinding::SMAstar::Examples::PalUtils::process_rev_words_by_density(\@words, $sparsity);
if(!@word_objs){
print STDERR "no words achieve density specified by max sparsity $sparsity\n";
exit;
}
$num_word_objs = @word_objs;
diag("loading avl trees.");
for (my $i = 0; $i < @word_objs; $i++) {
show_progress($i/$num_words);
my $word = $word_objs[$i]->{_word};
my $rev_word = $rev_word_objs[$i]->{_word};
$avltree->insert($word_objs[$i]);
$avltree_rev->insert($rev_word_objs[$i]);
}
show_progress(1);
print STDERR "\n";
#
# Build the words-with-candidates list. This will be used for phrases that are
# palindromes with a space in the middle position. The descendants of these
# types of palindromes are found by sort-of starting all over again... any word becomes
# a candidate for the extension of the palindrome- any word that has candidates,
# that is. By building a list of only the words that have candidates,
# the search time is greatly reduced.
#
my $i = 0;
diag("building words_w_cands_list.");
foreach my $w (@words){
show_progress($i/$num_words);
my @candidates = AI::Pathfinding::SMAstar::Examples::PalUtils::get_cands_from_left($w, $avltree, $avltree_rev);
if(@candidates){
push(@words_w_cands, $w);
}
$i++;
}
show_progress(1);
print STDERR "\n";
my $num_words_w_cands = @words_w_cands;
diag("number of word/candidate pairs is: $num_words_w_cands.");
$avltree_height = $avltree->get_height();
$avltree_rev_height = $avltree_rev->get_height();
diag("AVL trees loaded. Heights are $avltree_height, $avltree_rev_height\n\n");
my @phrase_obj_list;
my $smastar;
ok(
$smastar = AI::Pathfinding::SMAstar->new(
_state_eval_func => AI::Pathfinding::SMAstar::Examples::Phrase::evaluate($min_letters),
_state_goal_p_func => AI::Pathfinding::SMAstar::Examples::Phrase::phrase_is_palindrome_min_num_chars($min_letters),
_state_num_successors_func => \&AI::Pathfinding::SMAstar::Examples::Phrase::get_num_successors,
_state_successors_iterator => \&AI::Pathfinding::SMAstar::Examples::Phrase::get_descendants_iterator,
_state_get_data_func => \&AI::Pathfinding::SMAstar::Examples::Phrase::roll_up_phrase,
_show_prog_func => sub{ },
#_show_prog_func => \&AI::Pathfinding::SMAstar::Examples::PalUtils::show_progress_so_far,
),
'created smastar');
diag("smastar object created");
foreach my $word (@words_w_cands){
my $sparsity = AI::Pathfinding::SMAstar::Examples::PalUtils::get_word_sparsity($word);
my $len_word = length($word);
my $num_chars = AI::Pathfinding::SMAstar::Examples::PalUtils::num_chars_in_word($word);
my $cost = $sparsity + $len_word;
my $phrase = AI::Pathfinding::SMAstar::Examples::Phrase->new(
_word_list => \@words,
_words_w_cands_list => \@words_w_cands,
_dictionary => $avltree,
_dictionary_rev => $avltree_rev,
_start_word => $word,
_word => $word,
_cost => $cost,
_letters_seen => [],
_cost_so_far => 0,
_num_chars_so_far => 0,
_num_new_chars => $num_chars,
);
diag("inserting word $word");
$smastar->add_start_state($phrase);
}
# diag("starting SMA* search...");
my $palindorme_phr_obj;
$palindrome_phr_obj = $smastar->start_search(
\&log_function,
\&str_function,
$max_states_in_queue,
$MAX_COST,
);
my $palindrome;
if($palindrome_phr_obj){
$palindrome = $palindrome_phr_obj->{_state}->roll_up_phrase();
}
diag("ran SMA search: palindrome is '$palindrome'");
is( $palindrome, 'lid off a daffodil ', 'palindrome is [lid off a daffodil ]' );
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";
}
my $str = "";
# $cand is the parent's word (the candidate that generated this phrase)
my $cand = "";
my $cost = "";
my $cost_so_far = "";
my $num_new_chars = "";
my $num_chars_so_far = "";
my $letters_seen = [];
my $letters_seen_str = join("", @$letters_seen);
my $phrase = "";
my $evaluation = -1;
my $depth = 0;
$str = $path_obj->{_state}->{_start_word};
# $cand is the parent's word (the candidate that generated this phrase)
$cand = defined($path_obj->{_state}->{_cand}) ? $path_obj->{_state}->{_cand} : "";
$cost = $path_obj->{_state}->{_cost};
$cost_so_far = $path_obj->{_state}->{_cost_so_far};
$num_new_chars = $path_obj->{_state}->{_num_new_chars};
$num_chars_so_far = $path_obj->{_state}->{_num_chars_so_far};
$letters_seen = $path_obj->{_state}->{_letters_seen};
$letters_seen_str = join("", @$letters_seen);
$phrase = defined($path_obj->{_state}->{_phrase}) ? $path_obj->{_state}->{_phrase} : "";
$evaluation = AI::Pathfinding::SMAstar::Path::fcost($path_obj);
$depth = $path_obj->{_depth};
$num_chars_so_far = sprintf("%02d", $num_chars_so_far);
$num_new_chars = sprintf("%02d", $num_new_chars);
$cost = sprintf("%02d", $cost);
$cost_so_far = sprintf("%02d", $cost_so_far);
$depth = sprintf("%02d", $depth);
my $specifier = "%" . $max_word_length . "s";
$str = sprintf($specifier, $str);
$evaluation = sprintf("%04f", $evaluation);
$letters_seen_str = sprintf("%26s", $letters_seen_str);
my $log_str = "";
$log_str = $log_str . "depth: $depth, ";
$log_str = $log_str . "eval: $evaluation, ";
$log_str = $log_str . "letters: '$letters_seen_str', ";
$log_str = $log_str . "'$str', ";
$log_str = $log_str . "'$phrase', ";
$log_str = $log_str . "cand: $cand";
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;
}
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 = "|";
}
elsif($state == 3){
$spinny_thing = "/";
}
my ($progress) = @_;
my $stars = '*' x int($progress*10);
my $percent = sprintf("%.2f", $progress*100);
$percent = $percent >= 100 ? '100.00%' : $percent.'%';
print STDERR "\r$stars $spinny_thing $percent.";
flush(STDERR);
}
}
( run in 0.317 second using v1.01-cache-2.11-cpan-4d50c553e7e )