http://qs321.pair.com?node_id=351009

Lexicon has asked for the wisdom of the Perl Monks concerning the following question:

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" ; }

Replies are listed 'Best First'.
Re: Combining Branches in Trees
by Lexicon (Chaplain) on May 06, 2004 at 07:54 UTC
    Just to be thorough, I thought I'd include some testing code to give more hints as to how this is supposed to work.
    #!/usr/bin/perl use warnings; use strict; use Data::Dumper; # Be sure to copy the subroutine code into here. my @tree1 = ( [ [ 'red', 'orange', 'yellow', undef, undef, + undef ], [ undef, undef, undef, 'cyan', 'magent +a', 'black' ] ], [ [ 'red', undef, 'yellow', undef, 'magent +a', undef ], [ undef, 'orange', undef, 'cyan', undef, + 'black' ] ], ); my @done =( [ [ 'red', 'orange', 'yellow', 'cyan', 'magent +a', 'black' ], [ 'red', 'orange', 'yellow', 'cyan', 'magent +a', 'black' ] ] ); my @tree2 = Combine_Branches (\@tree1, 1, 3); my $done_string = Dumper(@done); my $tree2_string = Dumper(@tree2); print "Combine_Branches(\@tree1, 0, 3);\n"; if ( $done_string ne $tree2_string ) { print "Ack, not the same.\n"; print "$tree2_string\n"; print "$done_string\n"; } else { print "Everything is joy.\n" }