Combinations / permutations... not even sure what this is called

[tunafish]

Hi all,

So I'm working with a problem where I have n arrays. Let's say there are 3 of them:

('red','blue')

('small','medium','large')

(1,2,3,4)

I need to generate arrays containing as many elements as the last array with all possible combinations of elements from each of the arrays. So e.g.:

('red-small-1','red-small-2', 'red-small-3', 'red-small-4')

('red-medium-1','red-medium-2', 'red-medium-3', 'red-medium-4')

('red-large-1','red-large-2', 'red-large-3', 'red-large-4')

And the same thing for 'blue'.

This isn't a homework question. It's a real-life application and I've been breaking my head over this all day, even though I'm sure it can't be that complicated.

I'd really appreciate any help.

[toolic]

use warnings;
use strict;

for my $color (qw(red blue)) {
    for my $size (qw(sm med lrg)) {
        for my $num (1..4) {
            print "$color-$size-$num\n";
        }
    }
}

[ikegami]

If the N is dynamic, one can use Algorithm::Loops's NestedLoops.

use Algorithm::Loops qw( NestedLoops );

my @arrays = (
   [qw( red blue )],
   [qw( sm med lrg )],
   [ 1..4 ],
);

NestedLoops(
   \@arrays,
   sub { print(join('-', @_), "\n"); },
);

[moritz]

Perl 6 has that basically built-in with the X ("cross") operator:

say (('red','blue') X ('small','medium','large') X (1,2,3,4)).tree.map
+: *.join('-');

produces

red-small-1 red-small-2 red-small-3 red-small-4 red-medium-1 red-mediu
+m-2 red-medium-3 red-medium-4 red-large-1 red-large-2 red-large-3 red
+-large-4 blue-small-1 blue-small-2 blue-small-3 blue-small-4 blue-med
+ium-1 blue-medium-2 blue-medium-3 blue-medium-4 blue-large-1 blue-lar
+ge-2 blue-large-3 blue-large-4

[BrowserUk]

Shame you can't do infix ops in P5 :(

#! perl -slw
use strict;

sub X ($$) {
    my( $ra, $rb ) = @_;
    [
        map{
            my @x = ref() ? @$_ : $_;
            map[ ref() ? @$_ : $_, @x ], @$ra;
        } @$rb
    ]
}

my @c = ('red','blue');
my @s = ('small','medium','large');
my @n = (1,2,3,4);

print join ' - ', @$_ for @{ X( \@c, \@s ) };

print join ' - ', @$_ for @{ X( X( \@c, \@s ), \@n ) };

__END__
C:\test>xop
red - small
blue - small
red - medium
blue - medium
red - large
blue - large
red - small - 1
blue - small - 1
red - medium - 1
blue - medium - 1
red - large - 1
blue - large - 1
red - small - 2
blue - small - 2
red - medium - 2
blue - medium - 2
red - large - 2
blue - large - 2
red - small - 3
blue - small - 3
red - medium - 3
blue - medium - 3
red - large - 3
blue - large - 3
red - small - 4
blue - small - 4
red - medium - 4
blue - medium - 4
red - large - 4
blue - large - 4

[Marshall]

perhaps an adaption of this idea may be of use:

#!/usr/bin/perl -w
use strict;

print "$_\n" for (glob "{red,blue}-{small,medium,large}-{1,2,3,4}")

__END__
red-small-1
red-small-2
red-small-3
red-small-4
red-medium-1
red-medium-2
red-medium-3
red-medium-4
red-large-1
red-large-2
red-large-3
red-large-4
blue-small-1
blue-small-2
blue-small-3
blue-small-4
blue-medium-1
blue-medium-2
blue-medium-3
blue-medium-4
blue-large-1
blue-large-2
blue-large-3
blue-large-4

[johngg]

A little push in the right direction :-)

knoppix@Microknoppix:~$ perl -Mstrict -MData::Dumper -we '
> my @arr;
> push @{ $arr[ do { my $v = $1 - 1 if m{(\d+)$}  } ] }, $_
>    for glob q{{red,blue}-{small,medium,large}-{1,2,3,4}};
> print Data::Dumper->Dumpxs( [ \ @arr ], [ qw{ *arr } ] );'
@arr = (
         [
           'red-small-1',
           'red-medium-1',
           'red-large-1',
           'blue-small-1',
           'blue-medium-1',
           'blue-large-1'
         ],
         [
           'red-small-2',
           'red-medium-2',
           'red-large-2',
           'blue-small-2',
           'blue-medium-2',
           'blue-large-2'
         ],
         [
           'red-small-3',
           'red-medium-3',
           'red-large-3',
           'blue-small-3',
           'blue-medium-3',
           'blue-large-3'
         ],
         [
           'red-small-4',
           'red-medium-4',
           'red-large-4',
           'blue-small-4',
           'blue-medium-4',
           'blue-large-4'
         ]
       );
knoppix@Microknoppix:~$

I hope this is of interest.

Update: Looks like it might be the wrong direction as I've grouped from the wrong end. Oh well :-(

Update 2: Amended to do things the right way around but it's a bit clunkier :-(

knoppix@Microknoppix:~$ perl -Mstrict -MData::Dumper -we '
> my $idx;
> my %idxHash =
>    map { $_ => $idx ++ }
>    glob q{{red,blue}-{small,medium,large}};
> my @arr;
> push @{ $arr[ do { $idxHash{ $1 } if m{^(\w+-\w+)} } ] }, $_
>    for glob q{{red,blue}-{small,medium,large}-{1,2,3,4}};
> print Data::Dumper->Dumpxs( [ \ @arr ], [ qw{ *arr } ] );'
@arr = (
         [
           'red-small-1',
           'red-small-2',
           'red-small-3',
           'red-small-4'
         ],
         [
           'red-medium-1',
           'red-medium-2',
           'red-medium-3',
           'red-medium-4'
         ],
         [
           'red-large-1',
           'red-large-2',
           'red-large-3',
           'red-large-4'
         ],
         [
           'blue-small-1',
           'blue-small-2',
           'blue-small-3',
           'blue-small-4'
         ],
         [
           'blue-medium-1',
           'blue-medium-2',
           'blue-medium-3',
           'blue-medium-4'
         ],
         [
           'blue-large-1',
           'blue-large-2',
           'blue-large-3',
           'blue-large-4'
         ]
       );
knoppix@Microknoppix:~$

Update 3: Getting rid of the hash index look-up.

knoppix@Microknoppix:~$ perl -Mstrict -MData::Dumper -we '
> my @arr;
> my $idx = -1;
> push @{ $arr [ $_->[ 0 ] ] }, $_->[ 1 ] for
>    map { $idx ++; map { [ $idx, $_ ] } glob qq{$_-{1,2,3,4}} }
>       glob q{{red,blue}-{small,medium,large}};
> print Data::Dumper->Dumpxs( [ \ @arr ], [ qw{ *arr } ] );'
...

[Marshall]

Or perhaps as a push in the same direction:

#!/usr/bin/perl -w
use strict;
use Data::Dumper;

my @array;

foreach my $prefix (glob "{red,blue}-{small,medium,large}")
{
   my @sub_array;
   push @sub_array, "$prefix-$_" for (1,2,3,4);
   push @array, \@sub_array;
}
print Dumper \@array;

__END__
$VAR1 = [
          [
            'red-small-1',
            'red-small-2',
            'red-small-3',
            'red-small-4'
          ],
          [
            'red-medium-1',
            'red-medium-2',
            'red-medium-3',
            'red-medium-4'
          ],
          [
            'red-large-1',
            'red-large-2',
            'red-large-3',
            'red-large-4'
          ],
          [
            'blue-small-1',
            'blue-small-2',
            'blue-small-3',
            'blue-small-4'
          ],
          [
            'blue-medium-1',
            'blue-medium-2',
            'blue-medium-3',
            'blue-medium-4'
          ],
          [
            'blue-large-1',
            'blue-large-2',
            'blue-large-3',
            'blue-large-4'
          ]
        ];

Many variations are possible. I think there are some good ideas in this thread.

[roboticus]

tunafish:

Howzabout:

use strict;
use warnings;
use Data::Dumper;

my @AoA;

for my $color (qw(red blue)) {
    for my $size (qw(small medium large)) {
        push @AoA, [ map { "$color-$size-$_" } 1 .. 4 ];
    }
}

print Dumper(@AoA);

...roboticus

When your only tool is a hammer, all problems look like your thumb.

[Khen1950fx]

I counted 126 possible combinations using Math::Combinatorics.

#!/usr/bin/perl

use strict;
use warnings;
use Math::Combinatorics;

my @arrays = ( qw[ red blue ],
               qw[ small medium large ],
               qw[ 1 2 3 4 ],
);

print "combinations of 4 from: ".join(" ",@arrays)."\n";
print "-----------------------------".("--" x scalar(@arrays))."\n";
print join("\n", map { join " ", @$_ } combine(4,@arrays))."\n";

[JavaFan]

I counted 126 possible combinations using Math::Combinatorics

Considering 126 != 4 * 3 * 2, I'm claiming that your answer is wrong, without even looking at the code, or its output.

[JavaFan]

my @a = (
    [qw [red blue]],
    [qw [small medium large]],
);
my $l = [1..4];
splice @a, 0, 2, [map {my $x = $_; map {"$x-$_"} @{$a[1]}} @{$a[0]}] w
+hile @a > 1;
my @x = map {my $x = $_; [map {"$x-$_"} @$l]} @{$a[0]};
say "@$_" for @x;
__END__
red-small-1 red-small-2 red-small-3 red-small-4
red-medium-1 red-medium-2 red-medium-3 red-medium-4
red-large-1 red-large-2 red-large-3 red-large-4
blue-small-1 blue-small-2 blue-small-3 blue-small-4
blue-medium-1 blue-medium-2 blue-medium-3 blue-medium-4
blue-large-1 blue-large-2 blue-large-3 blue-large-4

[CountZero]

Digging very deep in my old maths knowledge, I think it is called Outer product or cross product and it is used in vector and matrix maths..

[remiah]

It's very interesting to see various ways of thinking and there is a lot to learn for me.

I thought SQL's cross join will give you what you want. In real world, sometimes values comes from database and if you use cross join in such case, it is very handy.

#!/usr/bin/perl

use strict;
use warnings;
use DBI;

my($dbh,$testdb);
$testdb='wnjpn.db';#SQLite database path

$dbh=DBI->connect("dbi:SQLite:$testdb","","", {AutoCommit=>0,RaiseErro
+r=>0});

#populate table
while(<DATA>){
    $dbh->do($_) or print DBI->errstr;
}
$dbh->commit;

#print with natural join
my $r=$dbh->selectall_arrayref( qq(
    select test_c.v || '-' ||test_s.v || '-' ||test_num.v as v
    from test_c cross join test_s cross join test_num;
)) or die DBI->errstr;
#),{ Slice => {} }) or die DBI->errstr;

use Data::Dumper;
print Dumper $r;

$dbh->disconnect;

__DATA__
drop table test_c;
drop table test_s;
drop table test_num;
create table test_s ( v text primary key);
create table test_c ( v text primary key);
create table test_num ( v text primary key);
insert into test_c values ( 'red');
insert into test_c values ( 'blue');
insert into test_s values ( 'small');
insert into test_s values ( 'medium');
insert into test_s values ( 'large');
insert into test_num values ( '1');
insert into test_num values ( '2');
insert into test_num values ( '3');
insert into test_num values ( '4');

[LanX]

Re: Combinations / permutations... not even sure what this is called

It's called cross-product.

You can use the glob-hack like Marshall did, as long as you have no problem with stringification.

Otherwise I have code mimicking Perl6's X-operator, if your interested I can post it on Monday.

PS: > This isn't a homework question.

I doubt this, only complete beginners don't know nested loops.

[Marshall]

I think calling my solution a "hack" is a bit too strong. It is a legal albeit not so obvious use of glob.

One thing is for sure, if this is a homework, the prof is going to freak out if the student presents my code as the homework answer! He/she just won't believe that it was unassisted.

I leave it to the OP to write some nested loops that will do the same job.