I wrote a rather elaborate/delicate/painful subroutine which combines redundant branches in a tree. It seems like there should be a well defined algorithm for doing this, but I didn't find anything here or on CPAN (couldn't think of good search terms, possibly) so I just wrote my own for the hell of it. But since it will be in production, I thought I'd rather use something tested, should it exist.
Should this be actually new and useful, I'd like to get comments and hear about bugs, as I'd probably eventually turn it into a real module.
####################################################################
# COMBINE BRANCHES
#-------------------------------------------------------------------
#
# Imagine a tree. Lets separate it into 3 parts: branches, twigs,
# and leaves. Leaves are a certain color: green, red, golden,
# ultraviolet... On this tree, there are different kinds of twigs,
# each growing leaves of a certain set of colors. If the twig grows
# leaves of a color, it is the ONLY twig to grow leaves of that
# color. So one kind of twig might grow green, red, and yellow,
# and another kind would grow purple, pink, and poka-dot. Twigs have
# lots of empty space where they *could* be growing the other colors
# of leaves; they just don't. Thus, we have a lot of redundant
# twigs, and we should instead combine all the leaves onto one twig.
# This subroutine accomplishes that.
#
# For the purposes of this subroutine, a tree is a arrays of arrays
# (of arrays of arrays...) to an arbitrary depth. The user passes
# a $twig_depth and $leaf_depth to the subroutine. The $twig_depth
# determines where branches become twigs, and similarly the
# $leaf_depth determines the depth of the leaves. The leaf 'color'
# is its array index. Arrays are presumably sparsly populated at
# the leaf level.
#
# To clarify/generalize, a $twig could have more sub-$twigs coming
# off it and it is the FIRST twig which determines the colors of
# the leaves. So when we're done combining leaves, we have one
# kind of twig left (which will be in array index 0). That's
# redundant too, so we remove that twig entirely, i.e. eliminating
# that entire depth of the tree ($depth -= 1 to all deeper
# elements).
#
# The subroutine is passed a reference to a $tree, the
# $twig_depth, and a $leaf_depth, and returns a reference to a
# $tree. Mind you, no copy of the tree is made; the first $tree is
# destroyed by this subroutine. Returning the new tree is necessary
# because $twig_depth could be 0, in which case you cannot set the
# original (outside of the subroutine) tree to point to the deeper
# twig. Perhaps the better way to deal with this is to pass a
# reference to a reference to an array, I am undecided.
#
# A future version of this subroutine will handle having the leaf
# colors scattered across all twigs, specifically how to combine
# them in case of collisions. See the TODO:'s towards the end.
#
####################################################################
sub Combine_Branches {
my $tree = $_[0];
my $twig_depth = $_[1];
my $leaf_depth = $_[2];
my @branches = (\$tree);
my @twigs = ();
my @branch_indeces = (0);
my @twig_indeces = (0);
my $depth = 0;
my $branch = \$tree; # REFERENCE TO THE REFERENCE!!!
my $twig = \$tree;
my $branch_index = 0;
my $twig_index = 1;
my $leaf_mode = 0;
my $loop_count = 0;
my $zero_count = 0;
if ($twig_depth >= $leaf_depth) { return };
while (1) {
$loop_count++;
if ($depth < 0) { last } # END LOOP
########### If less than branching depth, traverse branches
if ($depth < $twig_depth) {
if (exists $$branch->[$branch_index]) {
push @twigs, undef;
push @twig_indeces, 0;
push @branches, $branch;
push @branch_indeces, $branch_index;
$depth++;
$branch = \$$branch->[$branch_index];
$branch_index = 0;
$twig_index = 1;
# continue to next branch
} elsif ($branch_index < $#$$branch) {
$branch_index ++
# drop back a branch
} else {
$branch = pop @branches;
$branch_index = ( pop @branch_indeces ) + 1;
$depth --
}
}
########## If equal to branching depth, transition to traversing twigs
+.
elsif ($depth == $twig_depth) {
if (exists $$branch->[$twig_index]) {
push @twigs, $$branch;
push @twig_indeces, $twig_index;
push @branches, $branch;
push @branch_indeces, $branch_index;
$twig = $$branch->[$twig_index];
$branch = \$$branch->[0];
$branch_index = 0;
$twig_index = 0;
$leaf_mode = 1;
$depth++;
}
elsif ($twig_index < $#$$branch) { $twig_index++ }
else {
$$branch = $$branch->[0];
$branch = pop @branches ;
$branch_index = pop @branch_indeces;
pop @twigs;
pop @twig_indeces;
$branch_index++;
$depth --;
}
}
########## If over branching depth and under leaf depth, traverse twig
+s
elsif ($depth > $twig_depth and $depth < $leaf_depth) {
if (exists $twig->[$twig_index]) {
push @twigs, $twig;
push @twig_indeces, $twig_index;
push @branches, $branch;
push @branch_indeces, $twig_index;
$branch = \$$branch->[$twig_index];
$twig = $twig->[$twig_index];
$twig_index = 0;
$depth++;
}
# Next index towards twig
elsif ($twig_index < $#$twig) { $twig_index++ }
# Past end of subbranch, backtrack.
else {
$depth--;
$branch = pop @branches ;
$branch_index = ( pop @branch_indeces );
$twig = pop @twigs;
$twig_index = ( pop @twig_indeces ) + 1;
}
}
# If at leaf depth, copy leaves
elsif ($depth == $leaf_depth) {
if (defined $twig) {
if (defined $$branch ) {
# TODO: Possibly throw an error if there is overlap.
} else {
$$branch = $twig;
# TODO: Expand the possibility of combining leaves.
# Perhaps average, concatenate, overwrite, leave first
+, etc...
}
}
$branch = pop @branches ;
$twig = pop @twigs;
$branch_index = pop @branch_indeces;
$twig_index = ( pop @twig_indeces ) + 1;
$depth--;
}
# Else something went very wrong.
else { die "Inconsistent State, Leaf Mode = $leaf_mode, Depth = $d
+epth, $!" }
}
return ($tree ? $tree : []);
}
####################################################################
# PRINT STATE
#-------------------------------------------------------------------
# This is just a support subroutine for debugging. You call is with
# the function call below:
#
# print_state("This is a useful message",
# $depth, $branch_index, $twig_index, $tree,
# \@branches, \@branch_indeces,
# \@twigs, \@twig_indeces,
# $$branch, $twig );
#
####################################################################
sub print_state {
my ( $message, $depth,
$branch_index, $twig_index,
$tree, $branches, $branch_indeces,
$twigs, $twig_indeces,
$branch, $twig ) = @_;
print << "___STATE___";
<PRE>
<B>Depth:</B> $depth <B>Branch Index:</B> $branch_index <B>Twig Index:
+</B> $twig_index
<B>Message:</B> $message
<B>Tree:</B> @$tree
<B>Branch:</B> $branch <B>Index:</B> $branch_index <B>Branches:</B> @$
+branches <B>Branch Indeces:</B> @$branch_indeces
<B>Twig:</B> $twig <B>Twigs:</B> @$twigs <B>Twig Indeces:</B> @$twig_i
+ndeces
</PRE>
___STATE___
print "<PRE><B>Branch:</B>\n" . Dumper($branch) . "</PRE>\n" ;
print "<PRE><B>Twig:</B>\n" . Dumper($twig) . "</PRE>\n" ;
}
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.
