[Moscow.pm] Равномерная, рандомная сортировка

[Ruslan Zakirov]

Привет, dvhillard :)

Введение:

1) сгруппируем одинаковые элементы
2) введем L(g) - длина группы
3) задача отсутствия повторений не решается, если существует группа i,
где L(G(i)) = MAX(L(G(j))) для любого j и L(G(i)) > SUM(L(G(j)))+1 для
люого j != i. По простецки - если группа с максимальной длинной
длиннее объединения всех остальных групп. Доказать элементарно.
4) Введем понятие группа i в критичном состоянии, если L(G(i)) =
SUM(L(G(j))) + 1 где j != i. Доказательством от противного легко
доказывается, что в наборе не может быть две группы в критичном
состоянии. Понятно, что такая группа может иметь только максимальную
длинну во всем наборе.

Алгоритм:
0) Конец, если все группы пусты
1) Если есть группа в критичном состоянии, то берем элемент из нее. к пункту 0
2) Иначе выбираем "случайно" группу (пропорционально длиннам),
исключая группу с предыдущим элементом. К пункту 0

Одна и таже группа не может стать два раза подряд критичной, а значит
мы не сможем нарушить условие неповторения элементов. Если мы выбрали
элемент в пункте 2, то невозможно, что эта группа будет критичной на
следующем цикле, а следовательно не нарушается условие неповторения.

Из всего вышесказанного следует, что решение существует, при
соблюдении условия 3.

Вот и простой код в лоб:

use strict;
use warnings;

my @e = qw(a a a a a b b b c c c c d e e e e e e e e e e e e e e);
my %g;
$g{$_}++ foreach @e;

my @res;

my $last;
while ( keys %g ) {
    my $pick = find_critical();
    unless ( defined $pick ) {
        $pick = pick_except_last();
    }
    $g{$pick}--;
    delete $g{$pick} unless $g{$pick};
    push @res, $last = $pick;
}

print join( ' ', @e ), "\n";
print join( ' ', @res ), "\n";

sub find_critical {
    my $critical;
    my ($max, $rest) = (0, 0);
    foreach my $e ( keys %g ) {
        if ( $g{$e} > $max ) {
            $rest += $max;
            $max = $g{$e};
            $critical = $e;
        } else {
            $rest += $g{$e};
        }
    }
    return undef if $max < $rest + 1;
    return $critical if $max == $rest + 1;
    die "No solution, too many '$critical' elements";
}

sub pick_except_last {
    my @tmp;
    while ( my ($k,$v) = each %g ) {
        next if defined $last and $last eq $k;
        push @tmp, ($k) x $v;
    }
    return $tmp[ int rand @tmp ];
}



-- 
Best regards, Ruslan.