Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Generalizing Code: Generating Unique Permutations

by Anonymous Monk
on Oct 07, 2003 at 19:54 UTC ( #297373=perlquestion: print w/ replies, xml ) Need Help??
Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

Howdy all,

I have a function that I use sometimes when I need permutations (I do permutation-testing often for stats problems). Currently I require the user to pass the "cardinality": how many different elements to put in each class. Let me give a simple example first, before I show the code:

Data: a1, b2, c3 Cardinality: 1 Permutations: {a1, b2}, {a1, c3}, {b2, c3}, Data: a1, b2, c3, d4 Cardinality: 2 Permutations: {{a1, b2}, {c3, d4}} {{a1, c3}, {b2, d4}} {{a1, d4}, {c3, d4}}

I hope that's reasonably clear: cardinality defines the size of the group I wish to obtain permutations of. The first example above was: all possible pairs of groups of one element. The second example was: all possible pairs of groups of three elements (triplets). Within a single permutation, no element can be repeated, and I take only unique permutations.

I am generating all these permutations into a data-structure for later use (e.g. passing them to other software, writing them to file with their results, sending them to a DB, etc.). The code that does this is pretty simple, but unfortunately it has required me to HARDCODE the cardinality. It looks like this:

my @data; if ($cardinality == 1) { for (my $i = 0; $i < scalar(@$permlist); $i++) { for (my $j = 0; $j < scalar(@$permlist); $j++) { push @data, { first => [$$permlist[$i]], second => [$$permlist[$j]], }; } } } if ($cardinality == 2) { for (my $i = 0; $i < scalar(@$permlist); $i++) { for (my $j = 0; $j < scalar(@$permlist); $j++) { for (my $k = 0; $k < scalar(@$permlist); $k++) { for (my $p = 0; $p < scalar(@$permlist); $p++) { push @data, { first => [$$permlist[$i], $$permlist[$j]], second => [$$permlist[$k], $$permlist[$p]], }; } } } } }

And so on for higher cardinality. I would prefer to have a generalized way of doing this, rather than needing a separate set of for-loops for each cardinality. Is that possible? I'm turned it over in my head, and haven't found a way yet.

Comment on Generalizing Code: Generating Unique Permutations
Select or Download Code
Re: Generalizing Code: Generating Unique Permutations
by diotalevi (Canon) on Oct 07, 2003 at 19:57 UTC
Re: Generalizing Code: Generating Unique Permutations
by dragonchild (Archbishop) on Oct 07, 2003 at 20:16 UTC
    Please post your entire code. I'm seeing some possibilities, but I'd like to work with your complete code and be able to compare results with it. For example, I know you're setting $permlist somewhere and you're removing duplicates somewhere. I'd like to see the whole thing, including a few sample calls.

    ------
    We are the carpenters and bricklayers of the Information Age.

    The idea is a little like C++ templates, except not quite so brain-meltingly complicated. -- TheDamian, Exegesis 6

    Please remember that I'm crufty and crochety. All opinions are purely mine and all code is untested, unless otherwise specified.

Re: Generalizing Code: Generating Unique Permutations (iterator)
by tye (Cardinal) on Oct 07, 2003 at 21:42 UTC

    I hope to make a future version of Algorithm::Loops such that this is easier to write. However, you can still avoid having to generate the entire list into memory by avoiding duplicates as you go:

    #!/usr/bin/perl -w use strict; use Algorithm::Loops qw( NestedLoops ); my $permlist= [ 'a' .. shift(@ARGV)||'c' ]; my $max= $#$permlist; my $card= shift(@ARGV) || 1; my $iter= NestedLoops( [ [ 0 .. $max+1-2*$card ], sub { [ $_+1 .. $max ] }, map { my $left= $card - $_; sub { my %used; @used{@_}= (1) x @_; [ grep !$used{$_}, $_[-2]+1 .. $max+1-2*$left ]; }, sub { my %used; @used{@_}= (1) x @_; [ grep !$used{$_}, $_+1 .. $max ]; }, } 1 .. $card-1, ], ); ## my @data; my @idx; my $count; { my $prod= 1; my $mult= @$permlist; for( 1..$card ) { $prod *= $mult--; $prod /= $_; } for( 1..$card ) { $prod *= $mult--; $prod /= 2; } print "$prod pairings:\n"; } while( @idx= $iter->() ) { my @group; while( @idx ) { my @pair= @{$permlist}[ splice(@idx,0,2) ]; push @group, \@pair; } printf "( %s )\n", join ", ", map sprintf("(%s,%s)",@$_), @group; ## push @data, \@group; }
    See how easy that is? ;)

    A sample use is:

    > perl pairs.pl e 2 15 pairings: ( (a,b), (c,d) ) ( (a,b), (c,e) ) ( (a,b), (d,e) ) ( (a,c), (b,d) ) ( (a,c), (b,e) ) ( (a,c), (d,e) ) ( (a,d), (b,c) ) ( (a,d), (b,e) ) ( (a,d), (c,e) ) ( (a,e), (b,c) ) ( (a,e), (b,d) ) ( (a,e), (c,d) ) ( (b,c), (d,e) ) ( (b,d), (c,e) ) ( (b,e), (c,d) )

    Uncomment two lines to have the list of groups saved into @data.

    Update: Note that you can actually make that a bit faster such that most of the loop list constructors don't need the %used trick, but it makes the code a bit more complex to read:

    Which produces the same results though sorted in a different order.

                    - tye
Re: Generalizing Code: Generating Unique Permutations
by Anonymous Monk on Oct 07, 2003 at 21:58 UTC

    Here goes a larger (functional) code fragment, along with a test-case. The results of the test-case are below as well.

    use strict; sub getDistinctPermutations($$); ### RUN SUB my @data = ('A', 'B', 'C', 'D', 'E', 'F'); my $cardinality = 2; my $dataref = getDistinctPermutations(\@data, $cardinality); if ($dataref == 0) { die "Bad return\n"; } for (my $i = 0; $i < scalar(@$dataref); $i++) { my $element = $$dataref[$i]; print join(' ', @{$element->{first}}, @{$element->{second}}), "\n" +; } ### SUB sub getDistinctPermutations($$) { my $permlist = $_[0]; my $cardinality = $_[1]; if (scalar(@$permlist) < 2) { return 0; } elsif ($cardinality < 1) { return 0; } my @data; if ($cardinality == 1) { for (my $i = 0; $i < scalar(@$permlist); $i++) { for (my $j = 0; $j < scalar(@$permlist); $j++) { push @data, { first => [$$permlist[$i]], second => [$$permlist[$j]], }; } } } if ($cardinality == 2) { for (my $i = 0; $i < scalar(@$permlist); $i++) { for (my $j = $i+1; $j < scalar(@$permlist); $j++) { for (my $k = 0; $k < scalar(@$permlist); $k++) { for (my $p = $k+1; $p < scalar(@$permlist); $p++) { push @data, { first => [$$permlist[$i], $$permlist[$j]], second => [$$permlist[$k], $$permlist[$p]], }; } } } } } return \@data; }

    Which gives the results:

Re: Generalizing Code: Generating Unique Permutations
by ig (Vicar) on Dec 17, 2008 at 05:34 UTC

    Your various examples and descriptions seem a bit inconsistent to me, so I am probably misunderstanding something. None the less, the following appears to do what your last example does, without the hard coded nested loops. It could easily be modified for different combinations of combinations and variations (ouch!)

    update: replaced foreach loop in sub with a map to tidy it up.

    use strict; use warnings; use Algorithm::Combinatorics qw(combinations variations_with_repetitio +n); my @data = ('A', 'B', 'C', 'D', 'E', 'F'); my $cardinality = 2; for my $cardinality (1..3) { print "\n\nCardinality: $cardinality\n"; my $dataref = getPairsOfCombinations(\@data, $cardinality); if ($dataref == 0) { die "Bad return\n"; } for (my $i = 0; $i < scalar(@$dataref); $i++) { print "( " . join( ',', map { "( " . join(',', @{$_}) . " )" + } @{ $dataref->[$i] } ) . " )\n"; } } exit(0); sub getPairsOfCombinations { my ($data, $cardinality) = @_; my @combinations = combinations(\@data, $cardinality); my @variations = variations_with_repetition([0..$#combinations], 2 +); return [ map { [ map { $combinations[$_] } @{$_} ] } @variations ] +; }

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://297373]
Approved by naChoZ
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: (6)
As of 2014-07-24 23:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (167 votes), past polls