Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

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

by tunafish (Beadle)
on Oct 28, 2011 at 23:59 UTC ( #934537=perlquestion: print w/replies, xml ) Need Help??
tunafish has asked for the wisdom of the Perl Monks concerning the following question:

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.

  • Comment on Combinations / permutations... not even sure what this is called

Replies are listed 'Best First'.
Re: Combinations / permutations... not even sure what this is called
by toolic (Bishop) on Oct 29, 2011 at 00:24 UTC
    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"; } } }

      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"); }, );
Re: Combinations / permutations... not even sure what this is called
by moritz (Cardinal) on Oct 29, 2011 at 04:35 UTC

    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

      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

      With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
Re: Combinations / permutations... not even sure what this is called
by Marshall (Abbot) on Oct 29, 2011 at 09:05 UTC
    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

      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 } ] );' ...

      Cheers,

      JohnGG

        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.
Re: Combinations / permutations... not even sure what this is called
by roboticus (Chancellor) on Oct 29, 2011 at 00:29 UTC

    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.

Re: Combinations / permutations... not even sure what this is called
by Khen1950fx (Canon) on Oct 29, 2011 at 05:05 UTC
    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";
      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.
Re: Combinations / permutations... not even sure what this is called
by JavaFan (Canon) on Oct 29, 2011 at 00:21 UTC
    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
Re: Combinations / permutations... not even sure what this is called
by CountZero (Bishop) on Oct 29, 2011 at 07:36 UTC
    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..

    CountZero

    A program should be light and agile, its subroutines connected like a string of pearls. The spirit and intent of the program should be retained throughout. There should be neither too little or too much, neither needless loops nor useless variables, neither lack of structure nor overwhelming rigidity." - The Tao of Programming, 4.1 - Geoffrey James

Re: Combinations / permutations... not even sure what this is called
by remiah (Hermit) on Oct 30, 2011 at 01:12 UTC

    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');
Re: Combinations / permutations... not even sure what this is called (Cross-Product)
by LanX (Bishop) on Oct 29, 2011 at 11:27 UTC
    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.

    Cheers Rolf

    PS: > This isn't a homework question.

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

      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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://934537]
Approved by toolic
help
Chatterbox?
[Corion]: "Unmatched ) in regex; marked by <-- HERE in m/(&#9583;&# 9633;)&#9583;&# 65077; &#9531;&#9473;&# 9531;) <-- HERE / at -e line 1." :)
[Corion]: Meh - my "flip the table" string doesn't render here ;)
[choroba]: It renders correctly in pm-cb-g

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (8)
As of 2018-07-17 16:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    It has been suggested to rename Perl 6 in order to boost its marketing potential. Which name would you prefer?















    Results (372 votes). Check out past polls.

    Notices?