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

[Ruslan Zakirov]

Я тупил тупил, а потом понял, что рандома не нужно. В итоге все
достаточно равномерно, стабильно и прикольно:

a a a a a a a a a b b b b b b b b b c c
b a b a c b a b a b a b a b c a b a b a

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

use strict;
use warnings;

#my @e = (('a') x 100, ('b') x 100, ('c') x 100, ('d') x 100);
my @e = (('a') x 13, ('b') x 5, ('c') x 5, ('d') x 2);
my (%g, %d, %seen_on);
$g{$_}++ foreach @e;
$d{$_} = scalar(@e)/$g{$_} foreach @e;
$seen_on{$_} = -scalar(@e)/$g{$_}/2 foreach @e;
my @o = keys %g;

my @res;

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

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 @max = (- на e-1, undef);
    foreach my $k ( grep exists $g{$_}, @o ) {
        next if @res == $seen_on{$k};
        my $d = 1 + @res - $seen_on{$k} - $d{$k};
        next if $d < $max[0];

        @max = ($d,$k);
    }
    return $max[1];
}

2009/12/24 Андрей Костенко <andrey на kostenko.name>:
> В общем я проверял - в конце массива получались bcbcbcbc если по порядку :-)
> да, где-то вверху было:
> sub a {
>    my @a = @_;
>    my $v = int rand scalar @a;
>    my %a = ();
>    $a{$_} = ( $a{$_} || 0 ) + 1 foreach @a;
>    my @b = (undef) x scalar(@a);
>    my $i;
>    while ( grep { ! defined $_ } @b ) {
>        my @d = grep { (( $v == 0 || $_ ne $b[$v - 1]) && ($v ==
> scalar( @a ) - 1 || $_ ne $b[$v + 1])) } keys %a;
>        warn "@b\n", return a(@a) unless @d;
>        $_ = $d[ int rand scalar @d ];
>        --$a{$_} or delete $a{$_};
>        $b[$v] = $_;
>        my @v = grep  {! defined $b[$_]} (0..$#a);
>        last unless @v;
>        $v = $v[ int rand scalar @v];
>    }
>    return @b;
> }
> my @a = ( ('a') x 100, ('b') x 100, ('c') x 100, ('d') x 100 );
> say join " ", a(@a);
> sub a {
>    my @a = @_;
>    my $v = int rand scalar @a;
>    my %a = ();
>    $a{$_} = ( $a{$_} || 0 ) + 1 foreach @a;
>    my @b = (undef) x scalar(@a);
>    my $i;
>    while ( grep { ! defined $_ } @b ) {
>        my @d = grep { (( $v == 0 || $_ ne $b[$v - 1]) && ($v ==
> scalar( @a ) - 1 || $_ ne $b[$v + 1])) } keys %a;
>        warn "@b\n", return a(@a) unless @d;
>        $_ = $d[ int rand scalar @d ];
>        --$a{$_} or delete $a{$_};
>        $b[$v] = $_;
>        my @v = grep  {! defined $b[$_]} (0..$#a);
>        last unless @v;
>        $v = $v[ int rand scalar @v];
>    }
>    return @b;
> }
> my @a = ( ('a') x 100, ('b') x 100, ('c') x 100, ('d') x 100 );
> say join " ", a(@a);
>
>
> 2009/12/24 Ruslan Zakirov <ruslan.zakirov на gmail.com>:
>> 2009/12/23 Андрей Костенко <andrey на kostenko.name>:
>>> Возьмём 3000 позиций. Тогда с довольно большой вероятностью у нас закончится
>>> какой-то элемент раньше. Например на 2900-м элементе. После чего пойдёт
>>> bcbcbcbcbcbcbc.
>>
>> Почему? Вероятности вы определяете. Конечно такое получиться если у
>> вас 3000 элементов A, B, C и из них только небольшая доля элементов A.
>> Например, если 100 A на 3000 ABC, то вероятность появления хотя бы
>> одного A в последних 30 элементах должна быть близка к 1, а иначе у
>> вас не получиться равномерное распределение элементов.
>>
>> Опять же возникает вопрос. Нужно найти решение, которое наиболее
>> близкое к равномерному? Или любое, которое более или менее
>> равномерное?
>>
>>> Я это решал заполнением массива не по порядку, а случайным образом.
>>
>> Я пропустил решение? Я точно где-то что-то упустил и чего-то не понимаю.
>>
>>>
>>> 2009/12/23 Ruslan Zakirov <ruslan.zakirov на gmail.com>
>>>>
>>>> Ну не совсем так. По разному, но в общем у низкочастотного эелемента
>>>> мало шансов появится в начале.
>>>>
>>>> Что понимать под равномерной тогда? Если у нас 2 элемента X и всего 20
>>>> позиций, то на каких местах лучше разместить элементы X?
>>>>
>>>> * 1, 20?
>>>> * 5, 15?
>>>>
>>>> Все это решаемо вполне.
>>>>
>>>> 2009/12/23 Андрей Костенко <andrey на kostenko.name>:
>>>> > не всё так просто. в начале у нас будет выбираться элемент с
>>>> > вероятностью
>>>> > 0,2. А в конце пойдут два оставшиеся с веротностью 0.5. И в конце на
>>>> > больших
>>>> > длинах получается bcbcbcbcbc или acacacacac. Поэтому я и заполняю его не
>>>> > по
>>>> > порядку, а слуайным образом.
>>>> >
>>>> > 2009/12/23 Ruslan Zakirov <ruslan.zakirov на gmail.com>
>>>> >>
>>>> >> Привет, 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.
>>>> >> --
>>>> >> Moscow.pm mailing list
>>>> >> moscow-pm на pm.org | http://moscow.pm.org
>>>> >
>>>> >
>>>> > --
>>>> > Moscow.pm mailing list
>>>> > moscow-pm на pm.org | http://moscow.pm.org
>>>> >
>>>> >
>>>>
>>>>
>>>>
>>>> --
>>>> Best regards, Ruslan.
>>>> --
>>>> Moscow.pm mailing list
>>>> moscow-pm на pm.org | http://moscow.pm.org
>>>
>>>
>>> --
>>> Moscow.pm mailing list
>>> moscow-pm на pm.org | http://moscow.pm.org
>>>
>>>
>>
>>
>>
>> --
>> Best regards, Ruslan.
>> --
>> Moscow.pm mailing list
>> moscow-pm на pm.org | http://moscow.pm.org
>>
> --
> Moscow.pm mailing list
> moscow-pm на pm.org | http://moscow.pm.org
>



-- 
Best regards, Ruslan.