### Re: Permutation of groups

by Limbic~Region (Chancellor)
 on Nov 21, 2006 at 01:11 UTC ( #585180=note: print w/replies, xml ) Need Help??

in reply to Permutation of groups

tomazos,
This was an extremely tough cookie to crack so chances are I overcomplicated it. I plan on making a seperate writeup on this later.
```#!/usr/bin/perl
use strict;
use warnings;
use List::Util 'sum';

my \$group = ['A' .. 'E'];
my \$size  = 3;
my (\$rank_sub, \$unrank_sub) = gen_ranks(\$group);

my \$comb_iter = combo(\$size, @\$group);
while (my @comb = \$comb_iter->()) {
my \$iprt_iter = intpart(\$size);

while (my @ipart = \$iprt_iter->()) {
my \$part_iter = partition([@ipart], @comb);

while (my @part = \$part_iter->()) {
print join '', map "[@\$_] ", @part;
print "\n";

for (@part) {
my \$rank = \$rank_sub->(\$_);
my @team_from_rank = \$unrank_sub->(\$rank);
print "\tTeam: @\$_\n";
print "\tRank: \$rank\n";
print "\tRevd: @team_from_rank\n";
print "\n";
}
print "\n\n\n";
}
}
}

# Idea from [id://581697]
sub gen_ranks {
my \$all = shift @_;
my %pow_of_2 = map { \$all->[\$_] => 2 ** \$_ } 0 .. \$#\$all;
my %rev = reverse %pow_of_2;
return (
sub {
my \$team = shift @_;
return sum(map {\$pow_of_2{\$_}} @\$team);
},
sub {
my \$rank = shift @_;
my @team;
for (sort {\$b <=> \$a} keys %rev) {
if (\$_ <= \$rank) {
\$rank -= \$_;
unshift @team, \$rev{\$_};
}
last if ! \$rank;
}
return @team;
},
);

}

# From [id://533530]
sub partition {
my @block_size = sort { \$a <=> \$b } @{ shift(@_) };
my @items = @_;
@items == sum @block_size or die "sum of block sizes must equal nu
+mber of items";
my @rg;
return sub {
if ( !@rg ) {
@rg = map { (\$_) x \$block_size[\$_] } 0 .. \$#block_size;
} elsif ( ! next_rg_perm(\@rg) ) {
next_permute(\@block_size) or return;
@rg = map { (\$_) x \$block_size[\$_] } 0 .. \$#block_size;
}
my @return;
push @{ \$return[ \$rg[\$_] ] }, \$items[\$_] for 0 .. \$#items;
return @return;
};
}

# From [id://533530]
sub next_rg_perm {
my \$vals = shift;
my (\$candidate, @avail);
my \$i = @\$vals;
while (--\$i) {
(\$candidate) = grep defined, @avail[ \$vals->[\$i]+1 .. \$#avail
+];
last if  defined \$candidate
and grep { \$_ >= \$vals->[\$candidate]-1 } @\$vals[0..\$i-1];

\$avail[ \$vals->[\$i] ] = \$i;
}
return if \$i == 0;

@\$vals[\$i, \$candidate] = @\$vals[\$candidate, \$i];
@\$vals[\$i+1 .. \$#\$vals] = sort { \$a <=> \$b } @\$vals[\$i+1 .. \$#\$val
+s];
return 1;
}

# From [id://533530] adapted from tye's [id://29374]
sub next_permute {
my \$vals = shift;
return if @\$vals < 2;
my \$i = \$#\$vals - 1;
\$i-- until \$i < 0 or \$vals->[\$i] < \$vals->[\$i+1];
return if \$i < 0;
@\$vals[ \$i+1 .. \$#\$vals ] = reverse @\$vals[ \$i+1 .. \$#\$vals ];
my \$j = \$i+1;
\$j++ until \$vals->[\$i] < \$vals->[\$j];
@\$vals[\$i,\$j] = @\$vals[\$j,\$i];
return 1;
}

# From [id://393792]
sub intpart {
my \$target = shift;
return sub { () } if ! \$target || \$target =~ /\D/;
my @part = (0, (1) x (\$target - 1));
my \$done = undef;
return sub {
return () if \$done;
my \$min = \$part[-2];
my \$total = \$part[0] ? 0 : 1;
my \$index = 0;
for (0 .. \$#part - 1) {
if (\$part[ \$_ ] > \$min) {
\$total += \$part[\$_];
next;
}
\$index = \$_;
last;
}
\$part[\$index]++;
\$total += \$part[\$index];
if (\$total > \$target || \$part[\$index] > \$part[0]) {
@part = (\$index ? ++\$part[0] : \$part[0], (1) x (\$target -
+\$part[0]));
}
else {
@part = (@part[0 .. \$index], (1) x (\$target - \$total));
push @part, 1 if \$part[0] == 1;
}
\$done = 1 if \$part[0] == \$target;
return @part;
}
}

# From [id://393064]
sub combo {
my \$by = shift;
return sub { () } if ! \$by || \$by =~ /\D/ || @_ < \$by;
my @list = @_;
my @position = (0 .. \$by - 2, \$by - 2);
my @stop     = @list - \$by .. \$#list;
my \$end_pos  = \$#position;
my \$done     = undef;
return sub {
return () if \$done;
my \$cur = \$end_pos;
{
if ( ++\$position[ \$cur ] > \$stop[ \$cur ] ) {
\$position[ --\$cur ]++;
redo if \$position[ \$cur ] > \$stop[ \$cur ];
my \$new_pos = \$position[ \$cur ];
@position[ \$cur .. \$end_pos ] = \$new_pos .. \$new_pos +
+ \$by;
}
}
\$done = 1 if \$position[0] == \$stop[0];
return @list[ @position ];
};
}

I updated the rank()/unrank() though they still assume player names are are unique. If your real data is not unique, you will need to handle that by using indices of the group instead of values of the group.

Cheers - L~R

Create A New User
Node Status?
node history
Node Type: note [id://585180]
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?