File Coverage

blib/lib/Math/Permute/Lists.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	12	12	100.0
condition	3	3	100.0
subroutine	9	9	100.0
pod	1	2	50.0
total	86	87	98.8

=head1 Name

Math::Permute::Lists - Generate all the permutations of zero or more nested lists.

=head1 Synopsis

 use Math::Permute::Lists;

 permute {say "@_"}  [1,2],[3,4];

 # 1 2 3 4
 # 1 2 4 3
 # 2 1 3 4
 # 2 1 4 3
 # 3 4 1 2
 # 3 4 2 1
 # 4 3 1 2
 # 4 3 2 1

 permute {say "@_"} 1,[2,[3,4]];

 # 1 2 3 4
 # 1 2 4 3
 # 1 3 4 2
 # 1 4 3 2
 # 2 3 4 1
 # 2 4 3 1
 # 3 4 2 1
 # 4 3 2 1

=cut

use strict;

package Math::Permute::Lists;

use warnings FATAL => qw(all);
use strict;

sub permute(&@)                                                                 # Generate permutations of lists - user interface
 {my $s = shift;                                                                # Subroutine to call to process each permutation
  &Permute($s, undef, @_);                                                      # Perform permutations
 }

sub Permute                                                                     # Generate and expand permutations - private
 {my $S = shift;                                                                # User subroutine to call to process each permutation
  my $R = shift;                                                                # Subroutine to expand replacements

  my $Single = __PACKAGE__.'Single';                                            # User supplied item
  my $Expand = __PACKAGE__.'Expand';                                            # Sub permutations of user items
  my $mirror; $mirror = sub                                                     # Mirror permutation structure
   {my @p;                                                                      # Items to be permuted discovered at this level
    for(@_)
     {if (ref eq "ARRAY" or ref eq $Expand)                                     # Array of sub items to be permuted together
       {push @p, bless [0, bless $_, $Expand], $Single;                         # Not in use, sublist
       }
      else                                                                      # A single item
       {push @p, bless [0, $_], $Single;                                        # Not in use, user item
       }
     }
    @p                                                                          # Result
   };

  my $M = [&$mirror(@_)];                                                       # Mirrors the user supplied permutation structure but with additional data
  my @Q = ();                                                                   # Permuted array = output area
  my $N = 0;                                                                    # Number of permutations encountered

  my $replace; $replace = sub                                                   # Replace sub permutations with their expansions
   {my @q = @_;                                                                 # Fully or partially expanded row
    if (grep {ref($_) eq $Expand} @q)                                           # Check whether results if fully expanded yet
     {my @p;                                                                    # Prefix elements that are fully expanded
      for(;@q;)                                                                 # Remove leading block of items that do not need expansion
       {my $q = shift @q;                                                       # Each element, leaving trailing elements
        if (ref($q) ne $Expand)                                                 # Leading expanded elements
         {push @p, $q;                                                          # Save leading expanded element
         }
        else                                                                    # First element requiring expansion
         {&Permute($S, sub {&$replace(@p, @_, @q);}, @$q);                      # Expand sub permutation and use it to expand the current row
          return;
         }
       }
     }
    else                                                                        # Fully expanded - call user processing routine
     {++$N;                                                                     # Number of permutations encountered
      &$S(@q);                                                                  # Pass to user
     }
   };

  my $permute; $permute = sub                                                   # Generate permutations
   {if (scalar(@Q) == scalar(@$M))                                              # Row has been generated when it has enough elements
     {($R ? $R : $replace)->(map {$_->[1]} @Q);                                 # Subsequent or first replacement of user data
      return;
     }

    my ($P) = @_;                                                               # Permutations to be performed
    for my $p(@$P)                                                              # Find an item that has not been used so far in this permutation
     {if (!$p->[0])                                                             # Not in use
       {push @Q, $p;                                                            # Place it in the next position in the output area
        $p->[0] = 1;                                                            # Mark it as in use
        &$permute($P);                                                          # Choose again
        $p->[0] = 0;                                                            # Mark it as available
        pop @Q;                                                                 # Free space in output area
       }
     }
   };

  &$permute($M);                                                                # Permute per user
  $mirror = $replace = $permute = undef;                                        # Break memory cycles
  $N                                                                            # Return number of permutations performed
 }

# Export details

require 5;
require Exporter;

use vars qw(@ISA @EXPORT $VERSION);

@ISA     = qw(Exporter);
@EXPORT  = qw(permute);
$VERSION = '1.001';

=head1 Description

Generate all the permutations of zero or more nested lists using the standard
Perl metaphor.

C returns the number of permutations in both scalar and array
context.

C is 100% Pure Perl.

=head1 Export

The C 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

[e-mail]

http://www.appaapps.com

=head1 Acknowledgements

From a suggestion by Philipp Rumpf.

=head1 See Also

=over

=item L

=item L

=item L

=item L

=item L

=item L

=back

=head1 Copyright

Copyright (c) 2009 Philip R Brenan.

This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.

=cut