Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Multiple Permutation handling

by midget2000x (Novice)
on Mar 01, 2013 at 20:15 UTC ( #1021329=perlquestion: print w/ replies, xml ) Need Help??
midget2000x has asked for the wisdom of the Perl Monks concerning the following question:

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.

Comment on Multiple Permutation handling
Re: Multiple Permutation handling
by moritz (Cardinal) on Mar 01, 2013 at 20:27 UTC
Re: Multiple Permutation handling
by toolic (Chancellor) on Mar 01, 2013 at 20:32 UTC
    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.

Re: Multiple Permutation handling
by Kenosis (Priest) on Mar 01, 2013 at 21:00 UTC

    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.

      ++ 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% + --

      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)?

        In some shells, brace expansion is part of the filename patterns.
        لսႽ ᥲᥒ⚪⟊Ⴙᘓᖇ Ꮅᘓᖇ⎱ Ⴙᥲ𝇋ƙᘓᖇ

      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}";

      -- Ken

        ...perhaps I'm missing something.

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

Re: Multiple Permutation handling
by ggoebel (Sexton) on Mar 01, 2013 at 22:38 UTC

    "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__
Re: Multiple Permutation handling
by saberworks (Curate) on Mar 01, 2013 at 23:55 UTC
Re: Multiple Permutation handling
by midget2000x (Novice) on Mar 02, 2013 at 07:19 UTC
    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?
      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__
Re: Multiple Permutation handling
by Laurent_R (Parson) on Mar 03, 2013 at 23:01 UTC

    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.

      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
      

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://1021329]
Approved by davido
Front-paged by davido
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (7)
As of 2014-12-22 08:14 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (112 votes), past polls