Multiple Permutation handling

[midget2000x]

I'm trying to figure out some code that will loop thru pre-defined lists and output all combinations (concatenations). Specifically of shirts and size/color/etc options.

For example, here are some lists:

http://thewhiteroom.com/permutations.jpg

My code needs to output something like this: SKU1TSBLU
SKU1TSGRN
SKU1TSWHT
SKU1TSBLK
SKU1TMBLU
SKU1TMGRN
SKU1TMWHT
SKU1TMBLK
...
SKU5H2XWHT
SKU5H2XBLK

So basically every combination of every option for each sku.

I have been doing some looping and can get there in a very ugly, inefficient manner, but I just know there's an easier way.

Any help appreciated.

[moritz]

Algorithm::Loops to the rescue:

use 5.010;
use strict;
use warnings;
use Algorithm::Loops qw/NestedLoops/;

my @list = NestedLoops(
    [
        [ qw/SKU1 SKU2 SKU3/ ],
        [ qw/T S L H / ],
        [ qw/S M L XL 2X / ],
        [ qw/BLU GRN WHT BLK / ],
    ],
    sub { join '', @_ },
);
say join ' ', @list,

[Kenosis]

Here's a glob option:

use strict;
use warnings;

my $sku   = join ',', qw/SKU1 SKU2 SKU3/;
my $tslh  = join ',', qw/T S L H/;
my $size  = join ',', qw/S M L XL 2X /;
my $color = join ',', qw/BLU GRN WHT BLK/;

print "$_\n" for glob "{$sku}{$tslh}{$size}{$color}";

Partial output:

SKU1TSBLU
SKU1TSGRN
SKU1TSWHT
SKU1TSBLK
SKU1TMBLU
SKU1TMGRN
...
SKU3HXLWHT
SKU3HXLBLK
SKU3H2XBLU
SKU3H2XGRN
SKU3H2XWHT
SKU3H2XBLK

Update:Removed unnecessary dashes in the string and the substitution. Thanks, kcott.

[rjt]

++ for clever use of glob. It actually performs quite well in this case:

                   Rate Algorithm::Loops             glob     Nested l
+oops
Algorithm::Loops  371/s               --             -88%             
+-91%
glob             3059/s             724%               --             
+-27%
Nested loops     4219/s            1036%              38%             
+  --

Read more... (1458 Bytes)

[Laurent_R]

Hello dear Perl Monks,

On a cross-post of the same question by the OP on the DevShed forum, I answered with a suggestion almost identical to Toolic's nested foreach loops.

However, this use of the glob function puzzles me. After some tests and reading in detail the glob description, I found this passage: "If non-empty braces are the only wildcard characters used in the glob, no filenames are matched, but potentially many strings are returned. For example, this produces nine strings, one for each pairing of fruits and colors".

So, now I understand why glob is being used in this context, but can anyone tell me why glob is doing this sort of things, which seems to have little to do with the normal usage of glob (by "normal", I just mean the usage that I have been knowing for years, i.e. returning filename extensions or a list of filename matching a shell file pattern)?

[choroba]

In some shells, brace expansion is part of the filename patterns.

[kcott]

I was wondering why you added hyphens to the glob string and then added a map function to remove them. It seems like a lot of additional processing that has no real value: perhaps I'm missing something.

This code produces the same output that you posted:

use strict;
use warnings;

my $sku   = join ',', qw/SKU1 SKU2 SKU3/;
my $tslh  = join ',', qw/T S L H/;
my $size  = join ',', qw/S M L XL 2X /;
my $color = join ',', qw/BLU GRN WHT BLK/;

print "$_\n" for glob "{$sku}{$tslh}{$size}{$color}";

[Kenosis]

...perhaps I'm missing something.

No, you haven't missed anything. I did unnecessarily add elements and processes. Good catch! ++

[toolic]

Loops aren't so bad, and sometimes they're efficient, too:

use warnings;
use strict;

for my $i (1 .. 5) {
    for my $shirt (qw(T S L H)) {
        for my $size (qw(S M L XL 2X)) {
            for my $col (qw(BLU GRN WHT BLK)) {
                print 'SKU', $i, $shirt, $size, $col, "\n";
            }
        }
    }
}

Show your code.

[ggoebel]

"Takes a list or array of array references and returns a function that will return successive permutations of the referenced arrays. Avoids recursion so will work on abitrarily huge sets of data. Runtime scales linearly with the number of sets. Minimal memory usage." -- shotgunefx w/ ariels

use strict;
use warnings;
use integer;


my @data = (
    ['SKU'],
    [1..5],
    [qw(T S L H)],
    [qw(S M L XL 2X)],
    [qw(BLU GRN WHT BLK)]
);
my $iter = make_permutator(@data);
my ($idx, @idx_link);

while (my @els = $iter->() ){
  print @els, "\n";
}

sub make_permutator {
  @idx_link = (0, @_);
  return sub {
    $idx = $idx_link[0]++;
    my @ret;
    for my $i (1..$#idx_link) {
      push @ret, $idx_link[$i][$idx % @{$idx_link[$i]}];
      $idx /= @{$idx_link[$i]};
    }
    return $idx ? () : @ret;
  }
}

1;
__END__

[saberworks]

I had that same question quite a while ago, some similar and different answers there: Conglomerate of arrays with no duplicates

[midget2000x]

Thanks for the help guys, I really appreciate it. Anyone want a take on a curveball? What if some SKUs just have one set of options (like size only), but the next SKU has 3 sets (size, color, type), and the next one has 2 (size and color)? Can the code be make to "permutate" only over the available sets for each SKU?

[ggoebel]

use strict;
use warnings;
use integer;

# See http://www.perlmonks.org/?node_id=154008

my @permutation = (
    [['SKU'],[1..3],[qw(T S L H)],[qw(S M L XL 2X)],[qw(BLU GRN WHT BL
+K)]],
    [['SKU'],[4..5],[qw(S M L XL 2X)]],
    [['SKU'],[6],[qw(S M L XL 2X)],[qw(BLU GRN WHT BLK)]]
);

for my $p (@permutation) {
    my $iter = make_permutator(@$p);

    while (my @els = $iter->()){
        print @els, "\n";
    }
}

sub make_permutator {
  my @idx_link = (0, @_);
  my $idx;
  return sub {
    $idx = $idx_link[0]++;
    my @ret;
    for my $i (1..$#idx_link) {
      push @ret, $idx_link[$i][$idx % @{$idx_link[$i]}];
      $idx /= @{$idx_link[$i]};
    }
    return $idx ? () : @ret;
  }
}

1;
__END__

[Laurent_R]

Hi Midget

as noted above, I have suggested yesterday four nested foreach loops in my answer to your cross post on the DevShed forum:

foreach my $s1 (@set1) {
     foreach my $s2 (@set2) {
          foreach my $s3 (@sizes) {
               foreach my $s4 (@colors) {
                    print "$s1$s2$s3$s4\n";
               }
         }
     }
}

And I believe it is probably the best solution: clean, easy to read, easy to understand and efficient.

For the fun of it, however, let me suggest a kind of "Schwartzian" solution, which could also be called a "Lisp written in Perl" solution (or Scheme, or Haskell, or whatever functional language written in Perl):

my @sku   =  qw/SKU1 SKU2 SKU3/;
my @tslh  =  qw/t s l h/;
my @colors = qw/BLU GRN WHT BLK /;  
my @sizes = qw / S M L XL 2X /;

print map { $col = $_; map { $siz = $_; map {$a1 =$_; map "$_ $a1 $siz
+ $col\n", @sku;} @tslh} @sizes } @colors;

(I have added spaces between the fields to make the output easier to read.) This prints (I copy only the beginning and the end of the 240-line printout):

SKU1 t S BLU
SKU2 t S BLU
SKU3 t S BLU
SKU1 s S BLU
SKU2 s S BLU
...
SKU3 l 2X BLK
SKU1 h 2X BLK
SKU2 h 2X BLK
SKU3 h 2X BLK

The beauty (and fun) of this solution is of course that it holds in just one line of code (in pure Perl, without using a module to do the work behind the scene).

There are a number of downsides to this solution, however: first, it is far less easy to understand, it is actually hardly readable. Even though I just wrote it, I am not sure how I would explain it to make it clearly understandable.

To tell the truth, it was also a bit complicated for me to write it: it took me about 3 minutes to write the foreach nested loops above (which I did not even need to test), and and it took me slightly more than half an hour to get the nested map function calls to work correctly. So, in brief, this was just for the fun, I do not recommend this solution.

[ggoebel]

Everyone knows that debugging is twice as hard as writing a program in the first place. So if you're as clever as you can be when you write it, how will you ever debug it?
-- Brian Kernighan, "The Elements of Programming Style", 2nd edition, chapter 2