lib/Algorithm/C3.pm

   1
   2 package Algorithm::C3;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp 'confess';
   8
   9 our $VERSION = '0.01';
  10
  11 # this function is a perl-port of the
  12 # python code on this page:
  13 #   http://www.python.org/2.3/mro.html
  14 sub _merge {
  15     my (@seqs) = @_;
  16     my $class_being_merged = $seqs[0]->[0];
  17     my @res;
  18     while (1) {
  19         # remove all empty seqences
  20         my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
  21         # return the list if we have no more no-empty sequences
  22         return @res if not @nonemptyseqs;
  23         my $reject;
  24         my $cand; # a canidate ..
  25         foreach my $seq (@nonemptyseqs) {
  26             $cand = $seq->[0]; # get the head of the list
  27             my $nothead;
  28             foreach my $sub_seq (@nonemptyseqs) {
  29                 # XXX - this is instead of the python "in"
  30                 my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
  31                 # NOTE:
  32                 # jump out as soon as we find one matching
  33                 # there is no reason not too. However, if
  34                 # we find one, then just remove the '&& last'
  35                 ++$nothead && last if exists $in_tail{$cand};
  36             }
  37             last unless $nothead; # leave the loop with our canidate ...
  38             $reject = $cand;
  39             $cand = undef;        # otherwise, reject it ...
  40         }
  41         die "Inconsistent hierarchy found while merging '$class_being_merged':\n\t" .
  42             "current merge results [\n\t\t" . (join ",\n\t\t" => @res) . "\n\t]\n\t" .
  43             "mergeing failed on '$reject'\n" if not $cand;
  44         push @res => $cand;
  45         # now loop through our non-empties and pop
  46         # off the head if it matches our canidate
  47         foreach my $seq (@nonemptyseqs) {
  48             shift @{$seq} if $seq->[0] eq $cand;
  49         }
  50     }
  51 }
  52
  53 sub merge {
  54     my ($root, $_parent_fetcher) = @_;
  55     my $parent_fetcher = $_parent_fetcher;
  56     unless (ref($parent_fetcher) && ref($parent_fetcher) eq 'CODE') {
  57         $parent_fetcher = $root->can($_parent_fetcher) || confess "Could not find method $_parent_fetcher in $root";
  58     }
  59     return _merge(
  60         [ $root ],
  61         (map { [ merge($_, $_parent_fetcher) ] } $root->$parent_fetcher()),
  62         [ $parent_fetcher->($root) ],
  63     );
  64 }
  65
  66 1;
  67
  68 __END__
  69
  70 =pod
  71
  72 =head1 NAME
  73
  74 Algorithm::C3 - A module for merging lists using the C3 algorithm
  75
  76 =head1 SYNOPSIS
  77
  78   use Algorithm::C3;
  79
  80   # merging a classic diamond
  81   # inheritence graph like this:
  82   #
  83   #    <A>
  84   #   /   \
  85   # <B>   <C>
  86   #   \   /
  87   #    <D>
  88
  89   my @merged = Algorithm::C3::merge(
  90       'D',
  91       sub {
  92           # extract the ISA array
  93           # from the package
  94           no strict 'refs';
  95           @{$_[0] . '::ISA'};
  96       }
  97   );
  98
  99   print join ", " => @merged; # prints D, B, C, A
 100
 101 =head1 DESCRIPTION
 102
 103 This module implements the C3 algorithm. I have broken this out
 104 into it's own module because I found myself copying and pasting
 105 it way too often for various needs. Most of the uses I have for
 106 C3 revolve around class building and metamodels, but it could
 107 also be used for things like dependency resolution as well since
 108 it tends to do such a nice job of preserving local precendence
 109 orderings.
 110
 111 Below is a brief explanation of C3 taken from the L<Class::C3>
 112 module. For more detailed information, see the L<SEE ALSO> section
 113 and the links there.
 114
 115 =head2 What is C3?
 116
 117 C3 is the name of an algorithm which aims to provide a sane method
 118 resolution order under multiple inheritence. It was first introduced
 119 in the langauge Dylan (see links in the L<SEE ALSO> section), and
 120 then later adopted as the prefered MRO (Method Resolution Order)
 121 for the new-style classes in Python 2.3. Most recently it has been
 122 adopted as the 'canonical' MRO for Perl 6 classes, and the default
 123 MRO for Parrot objects as well.
 124
 125 =head2 How does C3 work.
 126
 127 C3 works by always preserving local precendence ordering. This
 128 essentially means that no class will appear before any of it's
 129 subclasses. Take the classic diamond inheritence pattern for
 130 instance:
 131
 132      <A>
 133     /   \
 134   <B>   <C>
 135     \   /
 136      <D>
 137
 138 The standard Perl 5 MRO would be (D, B, A, C). The result being that
 139 B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
 140 The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
 141 which does not have this same issue.
 142
 143 This example is fairly trival, for more complex examples and a deeper
 144 explaination, see the links in the L<SEE ALSO> section.
 145
 146 =head1 FUNCTION
 147
 148 =over 4
 149
 150 =item B<merge ($root, $func_to_fetch_parent)>
 151
 152 This takes a C<$root> node, which can be anything really it
 153 is up to you. Then it takes a C<$func_to_fetch_parent> which
 154 can be either a CODE reference (see L<SYNOPSIS> above for an
 155 example), or a string containing a method name to be called
 156 on all the items being linearized. An example of how this
 157 might look is below:
 158
 159   {
 160       package A;
 161
 162       sub supers {
 163           no strict 'refs';
 164           @{$_[0] . '::ISA'};
 165       }
 166
 167       package C;
 168       our @ISA = ('A');
 169       package B;
 170       our @ISA = ('A');
 171       package D;
 172       our @ISA = ('B', 'C');
 173   }
 174
 175   print join ", " => Algorithm::C3::merge('D', 'supers');
 176
 177 The purpose of C<$func_to_fetch_parent> is to provide a way
 178 for C<merge> to extract the parents of C<$root>. This is
 179 needed for C3 to be able to do it's work.
 180
 181 =back
 182
 183 =head1 CODE COVERAGE
 184
 185 I use B<Devel::Cover> to test the code coverage of my tests, below
 186 is the B<Devel::Cover> report on this module's test suite.
 187
 188  ------------------------ ------ ------ ------ ------ ------ ------ ------
 189  File                       stmt   bran   cond    sub    pod   time  total
 190  ------------------------ ------ ------ ------ ------ ------ ------ ------
 191  Algorithm/C3.pm           100.0  100.0   55.6  100.0  100.0  100.0   94.4
 192  ------------------------ ------ ------ ------ ------ ------ ------ ------
 193  Total                     100.0  100.0   55.6  100.0  100.0  100.0   94.4
 194  ------------------------ ------ ------ ------ ------ ------ ------ ------
 195
 196 =head1 SEE ALSO
 197
 198 =head2 The original Dylan paper
 199
 200 =over 4
 201
 202 =item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
 203
 204 =back
 205
 206 =head2 The prototype Perl 6 Object Model uses C3
 207
 208 =over 4
 209
 210 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
 211
 212 =back
 213
 214 =head2 Parrot now uses C3
 215
 216 =over 4
 217
 218 =item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
 219
 220 =item L<http://use.perl.org/~autrijus/journal/25768>
 221
 222 =back
 223
 224 =head2 Python 2.3 MRO related links
 225
 226 =over 4
 227
 228 =item L<http://www.python.org/2.3/mro.html>
 229
 230 =item L<http://www.python.org/2.2.2/descrintro.html#mro>
 231
 232 =back
 233
 234 =head2 C3 for TinyCLOS
 235
 236 =over 4
 237
 238 =item L<http://www.call-with-current-continuation.org/eggs/c3.html>
 239
 240 =back
 241
 242 =head1 AUTHOR
 243
 244 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
 245
 246 =head1 COPYRIGHT AND LICENSE
 247
 248 Copyright 2006 by Infinity Interactive, Inc.
 249
 250 L<http://www.iinteractive.com>
 251
 252 This library is free software; you can redistribute it and/or modify
 253 it under the same terms as Perl itself.
 254
 255 =cut