1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
|
=head1 Name
Math::Cartesian::Product - Generate the Cartesian product of zero or more lists.
=head1 Synopsis
use Math::Cartesian::Product;
cartesian {print "@_\n"} [qw(a b c)], [1..2];
# a 1
# a 2
# b 1
# b 2
# c 1
# c 2
cartesian {print "@_\n"} ([0..1]) x 8;
# 0 0 0 0 0 0 0 0
# 0 0 0 0 0 0 0 1
# 0 0 0 0 0 0 1 0
# ...
# 1 1 1 1 1 1 1 0
# 1 1 1 1 1 1 1 1
print "@$_\n" for
cartesian {"@{[reverse @_]}" eq "@_"}
([' ', '*']) x 8;
# * *
# * *
# * * * *
# * *
# * * * *
# * * * *
# * * * * * *
# * *
# * * * *
# * * * *
# * * * * * *
# * * * *
# * * * * * *
# * * * * * *
# * * * * * * * *
=cut
package Math::Cartesian::Product;
use Carp;
use strict;
sub cartesian(&@) # Generate the Cartesian product of zero or more lists
{my $s = shift; # Subroutine to call to process each element of the product
my @C = @_; # Lists to be multiplied
my @c = (); # Current element of Cartesian product
my @P = (); # Cartesian product
my $n = 0; # Number of elements in product
# return 0 if @C == 0; # Empty product per Philipp Rumpf
@C == grep {ref eq 'ARRAY'} @C or croak("Arrays of things required by cartesian");
# Generate each Cartesian product when there are no prior Cartesian products.
# The first variant builds the results array, the second does not per Justin Case
my $p; $p = wantarray() ? sub
{if (@c < @C)
{for(@{$C[@c]})
{push @c, $_;
&$p();
pop @c;
}
}
else
{my $p = [@c];
push @P, bless $p if &$s(@$p);
}
} : sub # List not required per Justin Case
{if (@c < @C)
{for(@{$C[@c]})
{push @c, $_;
&$p();
pop @c;
}
}
else
{++$n if &$s(@c);
}
};
# Generate each Cartesian product allowing for prior Cartesian products.
my $q; $q = wantarray() ? sub
{if (@c < @C)
{for(@{$C[@c]})
{push @c, $_;
&$q();
pop @c;
}
}
else
{my $p = [map {ref eq __PACKAGE__ ? @$_ : $_} @c];
push @P, bless $p if &$s(@$p);
}
} : sub # List not required per Justin Case
{if (@c < @C)
{for(@{$C[@c]})
{push @c, $_;
&$q();
pop @c;
}
}
else
{++$n if &$s(map {ref eq __PACKAGE__ ? @$_ : $_} @c);
}
};
# Determine optimal method of forming Cartesian products for this call
if (grep {grep {ref eq __PACKAGE__} @$_} @C)
{&$q
}
else
{&$p
}
$p = $q = undef; # Break memory loops per Philipp Rumpf
wantarray() ? @P : $n # Product or count per Justin Case
}
# Export details
require 5;
require Exporter;
use vars qw(@ISA @EXPORT $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(cartesian);
$VERSION = '1.009'; # Tuesday 18 Aug 2015
=head1 Description
Generate the Cartesian product of zero or more lists.
Given two lists, say: [a,b] and [1,2,3], the Cartesian product is the
set of all ordered pairs:
(a,1), (a,2), (a,3), (b,1), (b,2), (b,3)
which select their first element from all the possibilities listed in
the first list, and select their second element from all the
possibilities in the second list.
The idea can be generalized to n-tuples selected from n lists where all the
elements of the first list are combined with all the elements of the second
list, the results of which are then combined with all the member of the third
list and so on over all the input lists.
It should be noted that Cartesian product of one or more lists where one or
more of the lists are empty (representing the empty set) is the empty set
and thus has zero members; and that the Cartesian product of zero lists is a
set with exactly one member, namely the empty set.
C<cartesian()> takes the following parameters:
1. A block of code to process each n-tuple. this code should return true
if the current n-tuple should be included in the returned value of the
C<cartesian()> function, otherwise false.
2. Zero or more lists.
C<cartesian()> returns an array of references to all the n-tuples selected by
the code block supplied as parameter 1 if called in list context, else it
returns a count of the selected n-tuples.
C<cartesian()> croaks if you try to form the Cartesian product of
something other than lists of things or prior Cartesian products.
The cartesian product of lists A,B,C is associative, that is:
(A X B) X C = A X (B X C)
C<cartesian()> respects associativity by allowing you to include a
Cartesian product produced by an earlier call to C<cartesian()> in the
set of lists whose Cartesian product is to be formed, at the cost of a
performance penalty if this option is chosen.
use Math::Cartesian::Product;
my $a = [qw(a b)];
my $b = [cartesian {1} $a, $a];
cartesian {print "@_\n"} $b, $b;
# a a a a
# a a a b
# a a b a
# ...
C<cartesian()> is easy to use and fast. It is written in 100% Pure Perl.
=head1 Export
The C<cartesian()> function is exported.
=head1 Installation
Standard Module::Build process for building and installing modules:
perl Build.PL
./Build
./Build test
./Build install
Or, if you're on a platform (like DOS or Windows) that doesn't require
the "./" notation, you can do this:
perl Build.PL
Build
Build test
Build install
=head1 Author
Philip R Brenan at gmail dot com
http://www.appaapps.com
=head1 Acknowledgements
With much help and good natured advice from Philipp Rumpf and Justin Case to
whom I am indebted.
=head1 See Also
=over
=item L<Math::Disarrange::List>
=item L<Math::Permute::List>
=item L<Math::Permute::Lists>
=item L<Math::Permute::Partitions>
=item L<Math::Subsets::List>
=item L<Math::Transform::List>
=back
=head1 Copyright
Copyright (c) 2009-2015 Philip R Brenan.
This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.
=cut
|