Generating all possible combinations from an AoA

[Anonymous Monk]

This isn't really a Perl question, but more of a programming logic one. It just happens that the only language I'm a little fluent in is Perl.

Given an array of arrays of unknown dimensions, how do I generate all possible combinations, as in:

my @array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
    ); 

a1x, a1y, a2x, a2y, a3x, a3y, a4x, a4y, b1x, b1y, b2x, b2y, b3x, b3y, 
+b4x, b4y, c1x, c1y, c2x, c2y, c3x, c3y, c4x, c4y

Until now all I've managed is:

my @as = @{ $array[0] };
foreach my $a (@as) {
    my @bs = @{ $array[1] };
    foreach my $b (@bs) {
        my @cs = @{ $array[2] };
        foreach my $c (@cs) {
            print $a;
            print $b;
            print $c . ", ";
        }
    }
}

I need to abstract away from the indices (1,2,3) in that code, meaning I need this to work independent of dimension of the first array (it will always remain a array of arrays though, no further embedding is necessary).

Or am I approaching this wrong in the first place?

[GrandFather]

Use Algorithm::Loops.

[saberworks]

Conglomerate of arrays with no duplicates Similar question I asked a long time ago with example code using Algorithm::Loops.

[jwkrahn]

$ perl -le'
my @array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
    );

my $pattern = join "", map "{$_}", map join( ",", @$_ ), @array;

print for glob $pattern;
'
a1x
a1y
a2x
a2y
a3x
a3y
a4x
a4y
b1x
b1y
b2x
b2y
b3x
b3y
b4x
b4y
c1x
c1y
c2x
c2y
c3x
c3y
c4x
c4y

[BrowserUk]

#! perl -slw
use strict;

sub nFor(&@) {
    my $code = shift;
    die "First argument must be a code ref" unless ref( $code ) eq 'CO
+DE';
    my @limits = @_;

    my @indices = ( 0 ) x @limits;

    for( my $i = $#limits; $i >= 0; ) {
        $i = $#limits;
        $code->( @indices ), ++$indices[ $i ]
            while $indices[ $i ] < $limits[ $i ];
        $i = $#limits;
        $indices[ $i ] = 0, ++$indices[ --$i ]
            while $i >= 0 and $indices[ $i ] == $limits[ $i ];
    }
}

my @array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
);

nFor {
    print join '', map $array[ $_ ][ $_[ $_ ] ], 0 .. $#_
} map scalar @$_, @array;

__END__

c:\test>nfor
a1x
a1y
a2x
a2y
a3x
a3y
a4x
a4y
b1x
b1y
b2x
b2y
b3x
b3y
b4x
b4y
c1x
c1y
c2x
c2y
c3x
c3y
c4x
c4y

[JavaFan]

use 5.010;
sub mix {@_ ? map {my $x = $_; map "$x$_", mix(@_[1..$#_])} @{$_[0]} :
+ ""}
say for mix @array;

[thargas]

I like this one best. A nice simple recursive function using map.

[tye]

Just don't use it on a problem of interesting size, as it requires the entire list to be in memory at once.

[james2vegas]

Use File::Glob's bsd_glob function, something like:



use File::Glob (bsd_glob);
my @array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
    ); 

my $glob = join( '', map { '{' . join( ',', @$_ ) . '}' } @array );
my @list = bsd_glob($glob);



Update: I guess I approached this as a Perl programming problem not as a programming logic problem, oh well.

[LanX]

Approaches:

1.Metaprogramming

Generate dynamically a string of the above code with all nesting and eval it. (fast and intuitive!)

2. Recursion

Write a function X2() which gets two arrayrefs and returns an arr_ref of the cross product. Call it recursively until @array exceeded.

3. Reduce

is a variation of the above, with List::Util::reduce

use Data::Dumper;
 
#- crossproduct of two array refs
sub X2 {
  my ($a,$b)=@_;
  my @result;
  for my $x (@$a) {
    for my $y (@$b) {
      unless (ref($x) eq "ARRAY"){
        push @result, [$x,$y];
      }else{
        push @result, [(@$x,$y)];
      }      
    }
  }
  return \@result;
}
 
use List::Util qw/reduce/;
 
#- crossproduct of list of array refs
sub X { reduce { X2($a,$b) } @_ }
 
my @array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
); 
 
print Dumper X(@array);

The function X() now works somehow like the X operator in perl6, but of course you could also use reduce { X2($a,$b) } @array directly.

The function X2() could be rewritten with two nested maps, but thats a little two cryptic for my taste.

Bad ideas:

1. Glob

that's a hack which only works for strings as element type, everything else will be stringified, eg refs!!!

UPDATES:

* just noticed that you only want a simple concatenation of strings. That simplifies the code...

* There is a problem with this code .. the first one to spot it gets upvoted! :)

[eye]

When you have an indeterminate level of nesting, it is good to think about recursive solutions (as in JavaFan's solution).

[ikegami]

use Algorithm::Loops qw( NestedLoop );

my @terms = NestedLoop(\@array, sub { join '', @_ });

print(join(', ', @terms), "\n");

[Anonymous Monk]

Using foreach loops only:

my @results = ("");
foreach my $subarray (@array) {
    
    my @tmp_results = ();
    my @subarray = @{ $subarray };
    
    foreach my $tmp_result (@results) {
        foreach my $element (@subarray) {
            my $string = $tmp_result . $element;
            
            push @tmp_results, $string;
        }
    }
    @results = @tmp_results;
}
print join "\n", @results;
print "\n";

The trick is in the overwritting of @results with @tmp_results at the end of the outer loop, as well as in initializing @results with a single empty list in order for concatenation to work further down.

This could probably be written with several map's, but it might become difficult to read.

[choroba]

Like this?

@results = ('');
foreach my $subarray (@array) {
    @results = map {my $res = $_;
                    map $res.$_, @$subarray
                    } @results;
}
print join "\n", @results,'';

[Zarabozo]

Best answer to this problem I've seen so far, where everybody replies with long solutions or black boxes. Short, no globs, no modules, clear and readable. Very good! :-)

[dj_nitrkl]

Hi , I have approached this problem thru programming logic using recursive functions .May be its a little noobish but it gets the job done .any comments are welcome.

@array = (
    [ "a", "b", "c", ],
    [ "1", "2", "3", "4", ],
    [ "x", "y", ],
        ["A","B","C"]
    );
    our @initial_array = @{$array[0]};
     our $i = 1 ;
      $stop = scalar (@array)  ;
       recurse () ;
sub recurse () {
        $k = 0 ;
      foreach (@initial_array)
                  {

                      $firstelement = $_ ;
                         @next_array =  @{$array[$i]}  ;
                                   foreach (@next_array) {

                                                          $combination
+[$k]= $firstelement.$_ ;
                                                          $k++ ;


                                                         }



                  }


               @initial_array = @combination ; $i++ ;
               if ( $i == $stop )
                                {

                                print " @combination ";
                                 exit ;
                                }
               else {
                 recurse () ;
                   }
       }

output
______
a1xA a1xB a1xC a1yA a1yB a1yC a2xA a2xB a2xC a2yA a2yB a2yC a3xA a3xB 
+a3xC a3yA a3yB a3yC a4xA a4xB a4xC a4yA a4yB a4yC b1xA b1xB b1xC b1yA
+ b1yB b1yC b2xA b2xB b2xC b2yA b2yB b2yC b3xA b3xB b3xC b3yA b3yB b3y
+C b4xA b4xB b4xC b4yA b4yB b4yC c1xA c1xB c1xC c1yA c1yB c1yC c2xA c2
+xB c2xC c2yA c2yB c2yC c3xA c3xB c3xC c3yA c3yB c3yC c4xA c4xB c4xC c
+4yA c4yB c4yC

[raybies]

Here's my uber-inelegant serialized approach... If you don't care about the order that every combination is created: (btw, I renamed @array to be @arrays)...

my ($carry, @tallykeeper) = map 0, @arrays, 0; #gets rid of warnings..
+. w/strictures
while (!$carry) {
   $carry = 1;
   for my $dx (0 .. $#arrays ) { 
      print $arrays[$dx]->[$tallykeeper[$dx]]; 
      $tallykeeper[$dx] += $carry;
      if ($tallykeeper[$dx] < @{$arrays[$dx]}) {
          $carry = 0;
      }else{
          $tallykeeper[$dx] = 0;
      }
   }
   print "\n";
}

OR if you MUST have it in that order you could reverse the order of your array lists, or with my solution use this solution:

my ($carry, @tallykeeper) = map 0, @arrays, 0; #gets rid of warnings..
+.
while (!$carry) {
   $carry = 1;
   my $combostr = ""; 
   for my $dx (reverse 0 .. $#arrays ) { 
      $combostr .= $arrays[$dx]->[$tallykeeper[$dx]]; 
      $tallykeeper[$dx] += $carry;
      if ($tallykeeper[$dx] < @{$arrays[$dx]}) {
          $carry = 0;
      }else{
          $tallykeeper[$dx] = 0;
      }
   }
   $combostr = reverse $combostr;
   print "$combostr\n";
}

Okay mine are ultra lame... but it was fun to try to make a generic solution that worked for everything possible array of arrays...

--Ray

[raraya]

Approaching in a logical way, You can think this is a combinatory problem. You need to combine each index of each array with each other.

So if you have 3 arrays with 1, 2 and 3 elements you have 6 permutations of 3 elements each. In this case you need to generate 000, 001, 002, 010, 011 and 012.

To achieve this list you can iterate over total combinations incrementing the index of the array that hasnt reach its maximum order, and when it does you reset the index to "0" and increment the next (or previous depending the way you implement it) that hasnt reach it max everytime.

In code:

#!/usr/bin/perl -w

use strict;

my @array = ([ "a", "b", "c", ],
[ "1", "2", "3", "4", ],
[ "x", "y", ],
[ "U", "V", "W", "X", "Y", "Z",],);
my (@current, @result); # In @current we store the array index to cons
+truct the string

my $comb = 1;
map($comb *= @{$_}, @array); # Get total permutations

for (my $num = 1; $num <= $comb; $num++)
  {
  my $string = '';

  for (my $k = 0; $k <= $#array; $k++)
    {
    $current[$k] = 0 if !$current[$k];
    $string .= ${$array[$k]}[$current[$k]];
    }

  if ($current[$#array] < $#{$array[$#array]})
    {
    $current[$#array]++;
    }
  else #If we reach max index we increment previous not maxed one
    {
    $current[$#array] = 0;
    for (my $i = $#array-1; $i > -1; $i--)
      {
      # We exit the loop when we increment a not maxed index
      $current[$i] < $#{$array[$i]} ? do {$current[$i]++; last} : do {
+$current[$i] = 0};
      }
    }

  push(@result, $string);
  }

print join(",", @result) . "\n";

The execution:

[raraya@tolkien perl]$ aoa.pl
a1xU,a1xV,a1xW,a1xX,a1xY,a1xZ,a1yU,a1yV,a1yW,a1yX,a1yY,a1yZ,a2xU,a2xV,
+a2xW,a2xX,a2xY,a2xZ,a2yU,a2yV,a2yW,a2yX,a2yY,a2yZ,a3xU,a3xV,a3xW,a3xX
+,a3xY,a3xZ,a3yU,a3yV,a3yW,a3yX,a3yY,a3yZ,a4xU,a4xV,a4xW,a4xX,a4xY,a4x
+Z,a4yU,a4yV,a4yW,a4yX,a4yY,a4yZ,b1xU,b1xV,b1xW,b1xX,b1xY,b1xZ,b1yU,b1
+yV,b1yW,b1yX,b1yY,b1yZ,b2xU,b2xV,b2xW,b2xX,b2xY,b2xZ,b2yU,b2yV,b2yW,b
+2yX,b2yY,b2yZ,b3xU,b3xV,b3xW,b3xX,b3xY,b3xZ,b3yU,b3yV,b3yW,b3yX,b3yY,
+b3yZ,b4xU,b4xV,b4xW,b4xX,b4xY,b4xZ,b4yU,b4yV,b4yW,b4yX,b4yY,b4yZ,c1xU
+,c1xV,c1xW,c1xX,c1xY,c1xZ,c1yU,c1yV,c1yW,c1yX,c1yY,c1yZ,c2xU,c2xV,c2x
+W,c2xX,c2xY,c2xZ,c2yU,c2yV,c2yW,c2yX,c2yY,c2yZ,c3xU,c3xV,c3xW,c3xX,c3
+xY,c3xZ,c3yU,c3yV,c3yW,c3yX,c3yY,c3yZ,c4xU,c4xV,c4xW,c4xX,c4xY,c4xZ,c
+4yU,c4yV,c4yW,c4yX,c4yY,c4yZ

---

Greetings Rod.