Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
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


In reply to Re: Permutation of groups by Limbic~Region
in thread Permutation of groups by tomazos

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (3)
As of 2024-04-24 02:37 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found