Re: Permutation of groups

[Limbic~Region]

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.