Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

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


Comment on Re: Permutation of groups
Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://585180]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (14)
As of 2014-07-22 14:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (114 votes), past polls