Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

combinations of multiple variables which can assume multiple values

by jgraeve (Novice)
on Mar 16, 2018 at 15:52 UTC ( [id://1211055]=perlquestion: print w/replies, xml ) Need Help??

jgraeve has asked for the wisdom of the Perl Monks concerning the following question:

Hi Monks, I wish to create array @c from arrays @a and @b
@a = (1, 2, 3) @b = ("a", "b");
In @c I want all values of @a with all possible combinations of @b
@c = ( [ [1,"a"], [2,"a"], [3,"a"] ] , [ [1,"a"], [2,"a"], [3,"b"] ] , [ [1,"a"], [2,"b"], [3,"a"] ] , [ [1,"b"], [2,"a"], [3,"a"] ] , [ [1,"b"], [2,"b"], [3,"a"] ] , [ [1,"b"], [2,"b"], [3,"b"] ] )

What would we be the best way to accomplish this?

Thanks for helping out.

Johan

Replies are listed 'Best First'.
Re: combinations of multiple variables which can assume multiple values
by choroba (Cardinal) on Mar 16, 2018 at 16:21 UTC
    It's not clear what output you expect. Are you missing the following?
    [ [1,"a"], [2,"b"], [3,"b"] ], [ [1,"b"], [2,"a"], [3,"b"] ]

    If so, the following should work:

    #!/usr/bin/perl use warnings; use strict; my @a = (1, 2, 3); my @b = qw( a b ); my @expected = ( [ [1, "a"], [2, "a"], [3, "a"] ], [ [1, "a"], [2, "a"], [3, "b"] ], [ [1, "a"], [2, "b"], [3, "a"] ], [ [1, "b"], [2, "a"], [3, "a"] ], [ [1, "b"], [2, "b"], [3, "a"] ], [ [1, "b"], [2, "b"], [3, "b"] ], # [ [1, "a"], [2, "b"], [3, "b"] ], # [ [1, "b"], [2, "a"], [3, "b"] ], ); my %reverse_b; @reverse_b{@b} = 0 .. $#b; my @c = [ map [ $_, $b[0] ], @a ]; while (1) { my @indexes = map $reverse_b{ $_->[1] }, @{ $c[-1] }; my $r = $#indexes; while ($r >= 0) { if (++$indexes[$r] > $#b) { $indexes[$r--] = 0; } else { last } } last if $r < 0; push @c, [ map [ $a[$_], $b[ $indexes[$_] ]], 0 .. $#a ]; } use Test::More; use Test::Deep; cmp_deeply \@c, bag @expected; done_testing();

    Update: I forgot to mention: It works for any size of both the arrays.

    ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
      This is exactly what I needed. Thank you so much.
Re: combinations of multiple variables which can assume multiple values
by Cristoforo (Curate) on Mar 16, 2018 at 19:01 UTC
    Lacking the magic of solutions by LanX or choroba, this solution uses Algorithm::Combinatorics and List::MoreUtils.
    #!/usr/bin/perl use strict; use warnings; use Algorithm::Combinatorics 'variations_with_repetition'; use List::MoreUtils 'pairwise'; my @a = 1 .. 3; my @b = qw/a b/; my @c; my $iter = variations_with_repetition (\@b, scalar @a); while (my $tuple = $iter->next) { no warnings 'once'; # silence warnings about $a $b only used once my @temp = pairwise { [$a,$b] } @a, @$tuple; push @c, \@temp; } use Data::Dump; dd \@c;
    Dump output:
    [ [[1, "a"], [2, "a"], [3, "a"]], [[1, "a"], [2, "a"], [3, "b"]], [[1, "a"], [2, "b"], [3, "a"]], [[1, "a"], [2, "b"], [3, "b"]], [[1, "b"], [2, "a"], [3, "a"]], [[1, "b"], [2, "a"], [3, "b"]], [[1, "b"], [2, "b"], [3, "a"]], [[1, "b"], [2, "b"], [3, "b"]], ]

      Cool. Here is generalization for "n dimensions", e.g. I want an exhaustive list of combinations to build Perl variable names according to some pattern (silly example):

      use strict; use warnings; use feature 'say'; use Algorithm::Combinatorics 'variations_with_repetition'; use List::MoreUtils 'pairwise'; use Data::Dump 'dd'; my @subsets = ( [ qw/ $ @ % /], [ qw/ p q r s /], [ qw/ 0 1 /], ); my $base = shift @subsets; my $var_len = @$base; my @solutions = [ map [$_], @$base ]; for my $subset ( @subsets ) { my @variations = variations_with_repetition( $subset, $var_len ); @solutions = map { my $sol = $_; map [ pairwise { [ @$a, $b ] } @$sol, @$_ ], @variations } @solutions; } dd \@solutions;

      Output:

      [["\$", "p", 0], ["\@", "p", 0], ["%", "p", 0]], [["\$", "p", 0], ["\@", "p", 0], ["%", "p", 1]], [["\$", "p", 0], ["\@", "p", 1], ["%", "p", 0]], [["\$", "p", 0], ["\@", "p", 1], ["%", "p", 1]], [["\$", "p", 1], ["\@", "p", 0], ["%", "p", 0]], [["\$", "p", 1], ["\@", "p", 0], ["%", "p", 1]], [["\$", "p", 1], ["\@", "p", 1], ["%", "p", 0]], [["\$", "p", 1], ["\@", "p", 1], ["%", "p", 1]], [["\$", "p", 0], ["\@", "p", 0], ["%", "q", 0]], [["\$", "p", 0], ["\@", "p", 0], ["%", "q", 1]], [["\$", "p", 0], ["\@", "p", 1], ["%", "q", 0]], [["\$", "p", 0], ["\@", "p", 1], ["%", "q", 1]], [["\$", "p", 1], ["\@", "p", 0], ["%", "q", 0]], [["\$", "p", 1], ["\@", "p", 0], ["%", "q", 1]], [["\$", "p", 1], ["\@", "p", 1], ["%", "q", 0]], [["\$", "p", 1], ["\@", "p", 1], ["%", "q", 1]], [["\$", "p", 0], ["\@", "p", 0], ["%", "r", 0]], ... ... total 512 solutions
      As an exercise related to this problem (not solving the whole problem), I wanted to find an algorithm for 'variations_with_repetitions', (algorithms not being my strong suit), and was able to find a solution. I wouldn't say it is pretty, but it works :-)

      It doen't have an iterative solution. Instead it returns all the tuples.

      #!/usr/bin/perl use strict; use warnings; my $n = 3; my @a = "a".."b"; my @b = vw_rep(\@a, $n); # variations with repetition (Algorithm::Comb +inatorics) use Data::Dump; dd \@b; sub vw_rep { my ($ref, $n) = @_; my @c; for my $k (0 .. $n-1) { my $L = 0; for (1 .. @$ref**$k) { for my $i (0 .. $#$ref) { for (1 .. @$ref**($n-1 - $k)) { push @{ $c[$L++] }, $ref->[$i]; } } } } return @c; } __END__ C:\Old_Data\perlp>perl var_w_rep.pl [ ["a", "a", "a"], ["a", "a", "b"], ["a", "b", "a"], ["a", "b", "b"], ["b", "a", "a"], ["b", "a", "b"], ["b", "b", "a"], ["b", "b", "b"], ]
      Update: A better approach using choroba's solution in an iterative fashion could be:
      #!/usr/bin/perl use warnings; use strict; # Pm node 1211055 my $n = 3; my @b = qw( a b ); my $iter = variations_rep_iter(\@b, $n); while (my $tuple = $iter->()) { print "@$tuple\n"; } sub variations_rep_iter { my ($bases, $n) = @_; my @indices = (0) x $n; my $first = 1; my $iter = sub { if ($first) { $first = 0; return [ @$bases[ @indices ] ]; } my $r = $#indices; while ($r >= 0) { if (++$indices[$r] > $#$bases) { $indices[$r--] = 0; } else { last } } return if $r < 0; return [ @$bases[ @indices ] ]; }; return $iter; }
Re: combinations of multiple variables which can assume multiple values
by tybalt89 (Monsignor) on Mar 16, 2018 at 16:42 UTC

    Did you mean?

    #!/usr/bin/perl # http://perlmonks.org/?node_id=1211055 use strict; use warnings; use Data::Dump 'pp'; my @a = (1, 2, 3); my @b = ("a", "b"); my @bc = map [ split // ], glob +('{' . join(',', @b) . '}') x @a; my @c = map { my $t = $_; [ map [ $_, $t->[$_-1] ], 1..@a ] } @bc; pp @c;

    Outputs:

    ( [[1, "a"], [2, "a"], [3, "a"]], [[1, "a"], [2, "a"], [3, "b"]], [[1, "a"], [2, "b"], [3, "a"]], [[1, "a"], [2, "b"], [3, "b"]], [[1, "b"], [2, "a"], [3, "a"]], [[1, "b"], [2, "a"], [3, "b"]], [[1, "b"], [2, "b"], [3, "a"]], [[1, "b"], [2, "b"], [3, "b"]], )
Re: combinations of multiple variables which can assume multiple values
by LanX (Saint) on Mar 16, 2018 at 19:01 UTC
    straight forward,

    the solution for n columns constructed from n-1 columns successively.

    use strict; use warnings; use Data::Dump qw/pp dd/; my @a = 1 .. 3; my @b = "a".."b"; my @c =([]); # init one empty row for my $l (@a) { my @old = @c; @c =(); for my $r (@b) { for my $row (@old) { push @c, [ @$row , [$l,$r] ]; #push @c, [ (map [@$_], @$row) , [$l,$r] ]; # copy old-pairs +to new arrays } } #pp "old $l: ",@old; } warn "final:\n"; pp $_ for @c; pp \@c;
    [[1, "a"], [2, "a"], [3, "a"]] [[1, "b"], [2, "a"], [3, "a"]] [[1, "a"], [2, "b"], [3, "a"]] [[1, "b"], [2, "b"], [3, "a"]] [[1, "a"], [2, "a"], [3, "b"]] [[1, "b"], [2, "a"], [3, "b"]] [[1, "a"], [2, "b"], [3, "b"]] [[1, "b"], [2, "b"], [3, "b"]]

    NB: many subarray-refs repeat

    do { my $a = [ [[1, "a"], [2, "a"], [3, "a"]], [[1, "b"], [2, "a"], [3, "a"]], ['fix', [2, "b"], [3, "a"]], ['fix', [2, "b"], [3, "a"]], ['fix', 'fix', [3, "b"]], ['fix', 'fix', [3, "b"]], ['fix', 'fix', [3, "b"]], ['fix', 'fix', [3, "b"]], ]; $a->[2][0] = $a->[0][0]; $a->[3][0] = $a->[1][0]; $a->[4][0] = $a->[0][0]; $a->[4][1] = $a->[0][1]; $a->[5][0] = $a->[1][0]; $a->[5][1] = $a->[1][1]; $a->[6][0] = $a->[0][0]; $a->[6][1] = $a->[2][1]; $a->[7][0] = $a->[1][0]; $a->[7][1] = $a->[3][1]; $a; }

    if you want to avoid this, swap the comments in the push lines.

    update

    added version with tuple copy for non-shared refs

    update

    toggle the loops to have the order you (probably) wanted

    for my $row (@old) { for my $r (@b) {

    final: [[1, "a"], [2, "a"], [3, "a"]] [[1, "a"], [2, "a"], [3, "b"]] [[1, "a"], [2, "b"], [3, "a"]] [[1, "a"], [2, "b"], [3, "b"]] [[1, "b"], [2, "a"], [3, "a"]] [[1, "b"], [2, "a"], [3, "b"]] [[1, "b"], [2, "b"], [3, "a"]] [[1, "b"], [2, "b"], [3, "b"]]

    Cheers Rolf
    (addicted to the Perl Programming Language and ☆☆☆☆ :)
    Wikisyntax for the Monastery

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://1211055]
Approved by marto
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others cooling their heels in the Monastery: (4)
As of 2024-04-18 05:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found