use Carp 'confess';
-our $VERSION = '0.01';
-
-# this function is a perl-port of the
-# python code on this page:
-# http://www.python.org/2.3/mro.html
-sub _merge {
- my (@seqs) = @_;
- my $class_being_merged = $seqs[0]->[0];
- my @res;
- while (1) {
- # remove all empty seqences
- my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
- # return the list if we have no more no-empty sequences
- return @res if not @nonemptyseqs;
- my $reject;
- my $cand; # a canidate ..
- foreach my $seq (@nonemptyseqs) {
- $cand = $seq->[0]; # get the head of the list
- my $nothead;
- foreach my $sub_seq (@nonemptyseqs) {
- # XXX - this is instead of the python "in"
- my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
- # NOTE:
- # jump out as soon as we find one matching
- # there is no reason not too. However, if
- # we find one, then just remove the '&& last'
- ++$nothead && last if exists $in_tail{$cand};
+our $VERSION = '0.07';
+
+sub merge {
+ my ($root, $parent_fetcher, $cache) = @_;
+
+ $cache ||= {};
+
+ my @STACK; # stack for simulating recursion
+
+ my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
+
+ unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
+ confess "Could not find method $parent_fetcher in $root";
+ }
+
+ my $current_root = $root;
+ my $current_parents = [ $root->$parent_fetcher ];
+ my $recurse_mergeout = [];
+ my $i = 0;
+ my %seen = ( $root => 1 );
+
+ my ($new_root, $mergeout, %tails);
+ while(1) {
+ if($i < @$current_parents) {
+ $new_root = $current_parents->[$i++];
+
+ if($seen{$new_root}) {
+ my @isastack;
+ my $reached;
+ for(my $i = 0; $i < $#STACK; $i += 4) {
+ if($reached || ($reached = ($STACK[$i] eq $new_root))) {
+ push(@isastack, $STACK[$i]);
+ }
+ }
+ my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
+ die "Infinite loop detected in parents of '$root': $isastack";
}
- last unless $nothead; # leave the loop with our canidate ...
- $reject = $cand;
- $cand = undef; # otherwise, reject it ...
- }
- die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" .
- "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" .
- "mergeing failed on '$reject'\n" if not $cand;
- push @res => $cand;
- # now loop through our non-empties and pop
- # off the head if it matches our canidate
- foreach my $seq (@nonemptyseqs) {
- shift @{$seq} if $seq->[0] eq $cand;
+ $seen{$new_root} = 1;
+
+ unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
+ confess "Could not find method $parent_fetcher in $new_root";
+ }
+
+ push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
+
+ $current_root = $new_root;
+ $current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
+ $recurse_mergeout = [];
+ $i = 0;
+ next;
}
- }
-}
-sub merge {
- my ($root, $_parent_fetcher) = @_;
- my $parent_fetcher = $_parent_fetcher;
- unless (ref($parent_fetcher) && ref($parent_fetcher) eq 'CODE') {
- $parent_fetcher = $root->can($_parent_fetcher) || confess "Could not find method $_parent_fetcher in $root";
- }
- return _merge(
- [ $root ],
- (map { [ merge($_, $_parent_fetcher) ] } $root->$parent_fetcher()),
- [ $parent_fetcher->($root) ],
- );
+ $seen{$current_root} = 0;
+
+ $mergeout = $cache->{merge}->{$current_root} ||= do {
+
+ # This do-block is the code formerly known as the function
+ # that was a perl-port of the python code at
+ # http://www.python.org/2.3/mro.html :)
+
+ # Initial set (make sure everything is copied - it will be modded)
+ my @seqs = map { [@$_] } @$recurse_mergeout;
+ push(@seqs, [@$current_parents]) if @$current_parents;
+
+ # Construct the tail-checking hash (actually, it's cheaper and still
+ # correct to re-use it throughout this function)
+ foreach my $seq (@seqs) {
+ $tails{$seq->[$_]}++ for (1..$#$seq);
+ }
+
+ my @res = ( $current_root );
+ while (1) {
+ my $cand;
+ my $winner;
+ foreach (@seqs) {
+ next if !@$_;
+ if(!$winner) { # looking for a winner
+ $cand = $_->[0]; # seq head is candidate
+ next if $tails{$cand}; # he loses if in %tails
+
+ # Handy warn to give a output like the ones on
+ # http://www.python.org/download/releases/2.3/mro/
+ #warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
+ push @res => $winner = $cand;
+ shift @$_; # strip off our winner
+ $tails{$_->[0]}-- if @$_; # keep %tails sane
+ }
+ elsif($_->[0] eq $winner) {
+ shift @$_; # strip off our winner
+ $tails{$_->[0]}-- if @$_; # keep %tails sane
+ }
+ }
+
+ # Handy warn to give a output like the ones on
+ # http://www.python.org/download/releases/2.3/mro/
+ #warn " = " . join(' + ', @res) . "\n" if !$cand;
+
+ last if !$cand;
+ die q{Inconsistent hierarchy found while merging '}
+ . $current_root . qq{':\n\t}
+ . qq{current merge results [\n\t\t}
+ . (join ",\n\t\t" => @res)
+ . qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
+ if !$winner;
+ }
+ \@res;
+ };
+
+ return @$mergeout if !@STACK;
+
+ $i = pop(@STACK);
+ $recurse_mergeout = pop(@STACK);
+ $current_parents = pop(@STACK);
+ $current_root = pop(@STACK);
+
+ push(@$recurse_mergeout, $mergeout);
+ }
}
1;
=head1 NAME
-Algorithm::C3 - A module for merging lists using the C3 algorithm
+Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
=head1 SYNOPSIS
=over 4
-=item B<merge ($root, $func_to_fetch_parent)>
+=item B<merge ($root, $func_to_fetch_parent, $cache)>
This takes a C<$root> node, which can be anything really it
is up to you. Then it takes a C<$func_to_fetch_parent> which
for C<merge> to extract the parents of C<$root>. This is
needed for C3 to be able to do it's work.
+The C<$cache> parameter is an entirely optional performance
+measure, and should not change behavior.
+
+If supplied, it should be a hashref that merge can use as a
+private cache between runs to speed things up. Generally
+speaking, if you will be calling merge many times on related
+things, and the parent fetching function will return constant
+results given the same arguments during all of these calls,
+you can and should reuse the same shared cache hash for all
+of the calls. Example:
+
+ sub do_some_merging {
+ my %merge_cache;
+ my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
+ my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
+ my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
+ my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
+ # ...
+ }
+
=back
=head1 CODE COVERAGE
------------------------ ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
------------------------ ------ ------ ------ ------ ------ ------ ------
- Algorithm/C3.pm 100.0 100.0 55.6 100.0 100.0 100.0 94.4
+ Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
------------------------ ------ ------ ------ ------ ------ ------ ------
- Total 100.0 100.0 55.6 100.0 100.0 100.0 94.4
+ Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
------------------------ ------ ------ ------ ------ ------ ------ ------
=head1 SEE ALSO
=back
-=head1 AUTHOR
+=head1 AUTHORS
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
+Brandon L. Black, E<lt>blblack@gmail.comE<gt>
+
=head1 COPYRIGHT AND LICENSE
Copyright 2006 by Infinity Interactive, Inc.
projects / gitmo/Algorithm-C3.git / blobdiff