Perl Golf от REG.RU на YAPC::Europe 2013

1. Задачи даются на ученической доске размером 9×9.
2. Право хода — у чёрных камней.
3. Гарантируется, что на доске нет камней, которые уже захвачены.

На входе: девять строк, представляющих игровую доску, подаются на STDIN. Строки состоят из пробелов (обозначающих пустые точки на доске), символов «w» (белые камни) и «b» (чёрные камни), и завершаются символом переноса строки («n»).

На выходе: координаты (номер строки и номер столбца через пробел, нумерация с единицы) точек, ход на которые приводит к захвату белых камней. Должны быть выведены на STDOUT, по одной точке в строке. Должны быть выведены все имеющиеся на доске потенциальные ходы, приводящие к захвату белых камней. Точки должны быть выведены в порядке появления на доске слева направо и сверху вниз.

Соревнование проходит по обычным правилам Perl Golf:

1. Побеждает самая короткая программа, успешно прошедшая тесты.
2. Шебанг должен выглядеть как #!perl или #!perl -flags. #!perl не учитывается при подсчёте количества символов, но учитываются указанные флаги, включая символ(ы) «-».
3. Все остальные символы учитываются, включая пробелы и переводы строк.
4. Программа не может использовать другие модули, вызывать внешние программы или обращаться к внешним источникам данных.
5. Решение должно корректно работать на Perl версии 5.18.0, не выводя ничего на STDERR.

#!perl

# $/ устанавливаем в «1», чтобы «<>» считал входные данные без разбиения на
# строки (единица в них отсутствует). Заодно полученное значение используем для
# добавления начальной строки из 11 единиц (тогда позиция каждого символа/точки
# во входных данных становится сочетанием номера строки и номера столбца.
$b = ++$/ x 11 . <>;

# Обходим все точки доски.
for $i ( 9 .. 99 ) {
    # Делаем копию доски. Если обрабатываемая точка содержит пробел, т. е. пуста,
    # устанавливаем в неё «x» (по сути, произвольное значение, не являющееся ни
    # белым камнем, ни пустой точкой) и продолжаем.
    if ( ( $x = $b ) =~ s/^(.{$i}) /$1x/s ) {
        # Проверяем в полученной позиции доски все имеющиеся белые камни («w»).
        while ( $x =~ /w/g ) {
            # Копируем доску в $_, подсвечивая проверяемый белый камень «w» как «W»
            # (после регулярного выражения внутри условия while
            # $` содержит часть доски до проверяемой клетки, а в $' — после).
            $_ = "$`W$'";
            # Подсвечиваем все белые камни, соседствующие с уже подсвеченными.
            1 while s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s;
            # Ищем пробел (пустую точку) где-нибудь рядом с подсвеченной группой.
            /W((?<= .{10})|(?<= .)|(?=.{9} | ))/s
              # Если не нашли, то группа захвачена.
              # С помощью «/./» помещаем номер строки в $& (захваченная точкой
              # первая цифра) и $' (вторая цифра, идущая после захваченной части
              # строки), выводим. Сразу завершаем цикл, чтобы не было
              # дублирования одной точки в результате.
              || $i =~ /./ + ( print "$& $'n" ) + last;
        }
    }
}

#!perl

# Генерируем начальную строку с помощью диапазона символов d .. n,
# затем считываем входные данные.
@g = ( d .. n, map { /./g, '' } <> );

# Функция определения возможности захвата
sub n {
    my ( $i, $j, $r ) = @_;
    # Используем %s для хранения информации о проверенных точках
    # (чтобы избежать бесконечной рекурсии).
    # Помещаем соответствующий элемент %s в $_ с помощью map.
    map {
        # Устанавливаем в %s флаг проверенности точки
        # и проверяем точку, если она ещё не была проверена.
        $_ = 1 and map {
            # Если в текущей точке — белый камень, проверяем рекурсивно соседние
            # точки и считаем результат положительным, если получили
            # положительный результат только для одной из них
            # (т. е. одна точка имеет одно дыхание и группу можно захватить).
            $r =
                n( $i,     $j + 1 ) +
                n( $i,     $j - 1 ) +
                n( $i + 1, $j ) +
                n( $i - 1, $j ) == 1
                    if /w/;
            # Если точка пуста, считаем результат положительным
            # и запоминаем координаты в $0.
            $r = 1 and $0 = "$i $jn" if / /
        } $g["$i$j"] if !$_
    } $s{"$i$j"};
    # Возвращаем результат проверки
    $r
}
# Проходим по всем точкам доски.
map {
    # Если в точке стоит белый камень, ищем возможность его захвата
    # и выводим координаты найденной точки.
    print $0
      if $g[$_] eq 'w' && n(/./g)
} 0 .. 99

#!/usr/bin/perl
while (<>) {                        # Считываем входные данные,
    tr/ wbn/2133/;                 # заменяем символы в них на цифры.
    $str .= $_ . '3';
}
@m = split //, ( '3' x 12 ) . $str; # Добавляем первую строку из троек
                                    # и разбиваем в массив
for (@m) {
    %l = ();
    $r = 1;
    z($i);                          # Вызываем проверку.
    $o{ $w[0] } = 1                 # Запоминаем точку,
        if /1/                      # если в ней единица (белый камень),
        && $r                       # нет повтора,
        && ( @w = %l ) == 2;        # и найден только один пробел в соседях.
    $i++;
}

printf "%d %d$/", $_ / 11, $_ % 11  # Выводим координаты как результат и остаток
                                    # от деления позиции на 11
    for sort {$a > $b} keys %o;     # для всех найденных точек.

sub z {
    my $c = $_[0];
    for (qw/11 1 -11 -1/) {         # Для всех соседних клеток
        $x = $c + $_;               # получаем номер позиции,
        $n = $m[$x];                # получаем содержимое точки.
        $l{$x} = 1 if $n == 2;      # Запоминаем точку, если в соседях — пробел
        if ( $n == 1 ) {            # Если в соседях — белый камень,
            z($x) if !/-/;          # проверяем рекурсивно впереди идущие точки.
            $r = 0 if $i > $x       # Обнуляем флаг, если точка позади
                                    # изначально проверяемой точки
                                    # (чтобы исключить повторы)
        }
    }
}

#!perl
# Считываем входные данные, замыкая их в рамку из чёрных камней.
# Пробелы заменяем на 0, что позволит использовать проверку истинности.
$s = 'b' x 12;
while (<>) {
    s/n/bb/;
    s/ /0/g;
    $s .= $_;
}
$s .= 'b' x 10;

@q = ( -1, +1, 11, -11 ); # Сдвиги для координат соседних точек.

@a = split //, $s;        # Разбиваем доску и помещаем в массив.

for (@a) {                           # Обходим доску.
    ++$i;
    if ( !$a[$i] ) {                 # Если точка пуста.
        $res = 0;
        $p   = [];
        for (@q) {                   # Обходим соседние точки.
            $c = $_ + $i;
            if ( $a[$c] eq 'w' ) {   # Если в соседях белый камень.
                $p = [@a];           # Копируем доску
                $p->[$i] = 'b';      # Устанавливаем чёрный камень в проверяемую точку.
                $res += b( $p, $c ); # Проверяем «захваченность».
            }
        }
        if ($res) {                             # Если есть захват,
            printf "%d %dn", $i / 11, $i % 11; # вычисляем и выводим координаты точки.
        }
    }
}

sub b {
    my ( $e, $w ) = @_;
    $r = 1;
    for (@q) { # Обходим соседние точки. Практически дубль кода выше.
        $z = $_ + $w;
        return 0 if !$r || !$e->[$z];
        if ( $e->[$z] eq 'w' ) {
            $t = [@$e];
            $t->[$w] = 'b';
            $r &= b( $t, $z )
        }
    }
    return $r;
}

#!perl

# Считываем входные данные, замыкая их в рамку из чёрных камней
push @t, split //, 'b' x 11;
for (<>) {
    chomp;
    push @t, split //, "b$_" . "b"
}
push @t, @t[ 0 .. 10 ];

# Проходим по строкам и точкам
for ( ; $r++ < 11 ; ) {
    for ( $c = 0 ; $c++ < 11 ; ) {
        # Вычисляем позицию точки
        $i = $r * 11 + $c;
        # Если в точке - пробел, проверяем соседей
        if ( $t[$i] eq ' ' ) {
            for ( $i - 11, $i + 1, $i + 11, $i - 1 ) { 
                next unless $t[$_] eq 'w';
                $t[$i] = 'b';
                if ( f($_) > 7 ) {   # Если счётчик больше 7 (т. е. 8)
                    print "$r $cn"; # Выводим координаты
                    last
                }
                $t[$i] = ' '
            }
        }
    }
}

sub f {
    my ( $r, $e, $k ) = @_;
    $d{$r} ? return $e || $dr : ( $d{$r} = 2 );
    for ( $r - 11, $r + 1, $r + 11, $r - 1 ) { # Проверяем соседей
        $k += 1 + f( $_, 1 ) if $t[$_] eq 'w'; # Если сосед белый - добавляем к счётчику 1 плюс результат соседа
        $k += 2 if $t[$_] eq 'b';              # Добавляем к счётчику 2 если сосед чёрный
    }
    $e ? $k > 7 ? $e : 0 : $k;
}

#!perl -ln

    sub M {
        $k = pop;
        my %t;
        # Складываем «дыхания».
        $l[$k] = [ grep !$t{$_}++, @{ $l[$k] }, @_ ]
    }
    sub S {
        ( $m, $n ) = @_;
        ( $M, $N ) = sort $$m, $$n;
        # Устанавливаем числовые значения точек группы на наименьшее из входящих
        # и подсчитываем все «дыхания» группы
        M @{ delete $l[$N] }, $M
          if $N != ( $$m = $$n = $M );
    }

    $i = 1;
    # Разбиваем входные данные и проходим все точки.
    for ( split // ) {
        $b[ $c = $. . $i ] =       # Используем $. как счётчик строк.
            /w/ ? ++$e : $_;       # Заменяем белые камни на последовательно
                                   # увеличивающиеся числовые классы.
        $x = ( $R = $. - 1 ) . $i; # Позиция точки над текущей.
        $y = $. . ( $C = $i - 1 ); # Позиция точки слева от текущей.
        # Для белых камней — для камней сверху и слева
        /w/ && do {
            # делаем слияние групп числовых значений
            $b[$_] > 0 && S $b[$c], $b[$_] for $x, $y;
            # и суммируем «дыхания».
            M $b[$x] eq $" ? "$R $i" : (), $b[$y] eq $" ? "$. $C" : (), $b[$c];
        };
        # Для пустых точек — добавляем «дыхание» к камням сверху и слева.
        / / && map { $b[$_] > 0 && M "$. $i", $b[$_] } $x, $y;
        $i++;
    }
}{
    # Выводим результаты.
    print for sort grep !$s{$_}++, map @$_ - 1 ? () : @$_, @l

The core of the algorithm is to create groups of stone, and update
the list of freedoms for each group. At the end, only the freedoms
from groups with a single freedom are printed, after having been sorted
and deduplicated.

The algorithm uses @b for the board, and abuses the fact that it's a
9x9 board. So the coordinates are in the range 00..99 and $x.$y can
point to any intersection. When constructing the board, the column
and row 0 are filled with nothing (either undef or '').

The board is visited in a single pass, line by line (thanks to -ln).
For each cell, I looked at the cell above and on its left.

If the current cell is a 'w', it's turned into the next available
number, and for each neighbour, if it's a number, then both are turned
into the smallest of the two numbers, and their lists of freedoms are
merged. Neighbours that are ' ' are added to the list of freedoms for
the current cell.

If the current cell is a ' ', it's added as a freedom to those of its
neighbours that are numbers.

For 'b' cells, we do nothing.

The numbers are the 'equivalence classes' for the white groups, i.e.
two cells having the same number are part of the same group.

Printing the board was very useful to debug my algorithm:

    ...wb....          ...1b....
    ...b.....          ...b.....
    .........          .........
    ..b......  would   ..b......
    .bwb.....  become  .b2b.....
    bwwwb....          b222b....
    .........          .........
    .........          .........
    .......bw          .......b6

Without any merging of cells, the '2' group would actually be:

  2
 345

During the pass, it evolves like this:

    ..b......
    .b2

(visiting all cells until the next white)

    ..b......
    .b2......
    b3

    ..b......
    .b2b.....
    b34

merging the current cell (4) with 2:

    ..b......
    .b2b.....
    b32

merging the current cell (2) with 3:

    ..b......
    .b2b.....
    b22

    ..b......
    .b2b.....
    b225

merging the current cell (5) with 2:

    ..b......
    .b2b.....
    b222

The sub M does the addition of the freedoms, removing duplicates.
The sub S does the merging of the equivalence classes, and calls
M to merge their freedoms.

At 400, I had no expectation of winning. A well-known fact of golf
competitions is that regexp-based algorithms always win. :-)

#!perl
my $X = 121; # Размер поля с рамкой.
my $m;

# Подсчёт количества «несвободных» (чёрных или захваченных белых) камней в позиции доски.
sub z {
    my ( $s, $x, $m ) = shift;
    # Проверяем все точки и суммируем результат.
    while ( $x < $X ) { $m += f( $x++, $s ); }
    $m;
}

# Проверка точки на «несвободность»
sub f {
    my ( $n, $t, $d ) = @_;
    my $c = substr( $t, $n, 1 ); # Получаем значение точки.
    # Возвращаем 0 если точка пуста
    # или если мы не не находимся в рекурсии и в точке не стоит белый камень.
    return 0 if $c eq ' ' || !$d && $c ne 'w';
    # Возвращаем 1, если в точке стоит чёрный камень.
    return 1 if $c eq 'b';
    # Устанавливаем в точку чёрный камень.
    substr( $t, $n, 1 ) = 'b';
    # Рекурсивно проверяем соседние точки.
    ( !( ( $n + 1 ) % 11 ) || f( $n + 1, $t, 1 ) ) *
        ( !( ( $n - 1 ) % 10 ) || f( $n - 1, $t, 1 ) ) *
        f( $n + 11, $t, 1 ) *
        f( $n - 11, $t, 1 );
    # В итоге возвращаем 0, если рядом с группой камней
    # найдена хотя бы одна пустая точка.
}

# Считываем входные данные, замыкая их в рамку из чёрных камней.
my $y = 'b' x 11;
while (<>) {
    $y .= "b$_";
}
$y =~ s/n/b/g;
$y .= 'b' x 11;

$d = z($y);
my $i = 0;
while ( $i < $X ) {                   # Обходим доску.
    my $ch = substr( $y, $i, 1 );     # Получаем значение точки.
    if ( $ch eq ' ' ) {               # Если в точке пробел,
        $b = $y;                      # копируем доску,
        substr( $b, $i, 1 ) = 'b';    # устанавливаем в точку чёрный камень.
        # Если после проверки точки количество «несвободных» камней увеличилось
        if ( z($b) > $d ) {
            # Рассчитываем и выводим координаты.
            my $y = int( $i / 11 );
            my $x = $i - ( $y * 11 );
            print "$y $xn";
        }
    }
    $i++;
}

#!perl
eval {
    # Добавляем границы в начале и в конце.
    $a->[10] = $a->[0] = [ ('b') x 11 ];
    # Считываем данные, добавляя границы справа и слева.
    while (<STDIN>) {
        chomp;
        @{ $a->[ ++$i ] } = ( 'b', ( split '' ), 'b' );
        last if $i >= 9;
    }

    # Функция проверки захваченности белого камня.
    sub f {
        my ( $x, $y ) = @_;
        # Возвращаем имеющийся результат, если точка уже проверена.
        return $o[$j] if $n->[$x][$y];
        # Возвращаем имеющийся результат или 2, если на точке стоит чёрный камень.
        return $o[$j] || 2 if $a->[$x][$y] eq 'b';
        # Возвращаем единицу, если в точке не стоит белый камень (т. е. она пуста).
        return 1 if $a->[$x][$y] ne 'w';
        # Для белых камней запоминаем, что точка проверена,
        $n->[$x][$y] = $j;
        # и проверяем соседние точки.
        $o[$j] = f( $_, $y ) for ( $x - 1, $x + 1 );
        $o[$j] = f( $x, $_ ) for ( $y - 1, $y + 1 );
        # В результате $o[$j] получает значение 1 только если рядом с группой
        # камней найдена хотя бы одна пустая точка.
        return $o[$j];
    }

    # Функция проверки позиции доски.
    sub p {
        # Проходим по всем точкам.
        for $x ( 0 .. 10 ) {
            for $y ( 0 .. 10 ) {
                # Проверяем точку, если на ней стоит белый камень
                # и точка ещё не была проверена.
                f( $x, $y, $j++ ) if $a->[$x][$y] eq 'w' && !$n->[$x][$y];
            }
        }
        # Возвращаем количество установленных после проверки двоек
        # (т. е. чёрных камней и захваченных белых).
        return grep { $_ == 2 } @o;
    }

    my $t = p;                           # Инициализируем.
    for $x ( 0 .. 10 ) {                 # Проходим все точки.
        for $y ( 0 .. 10 ) {
            next if $a->[$x][$y] ne ' '; # Пропускаем, если точка не пуста.
            $a->[$x][$y] = 'b';          # Устанавливаем в точку чёрный камень.
            @o = ();                     # Обнуляем результаты.
            $n = [];                     # Обнуляем информацию о проверенных точках.
            print "$x $yn" if $t < p;   # Выводим координаты точки, если после
                                         # её проверки стало больше двоек
                                         # (т. е. были захвачены новые камни).
            $a->[$x][$y] = ' ';          # Убираем поставленный камень.
        }
    }
}

#!perl -ln0aF//
# Активно используем флаги:
# -n добавляет «while () { … }» вокруг кода;
# -0 позволяет считать входные данные целиком, не разбивая на строки;
# -a включает автосплит, разбивая входную строку и помещая в @F;
# -F// заставляет -a разбивать строку посимвольно;
# -l автоматически добавляет перевод строки в print.

# Функция проверки «захваченности» точки
sub c {
    my $s = pop;
    # Считаем захваченной, если
    # позиция выходит за границы поля (отрицательная или содержит девятку),
    $s =~ /-|9/
      # или точка занята чёрным камнем,
      || $g[$s] eq 'b'
      # или точка занята белым камнем и нет незахваченных соседей.
      || $g[$s] =~ /w/ * !grep { $g[$s] = 'b'; !c( $s + $_ ) } 1, -1, 10, -10;
}
# Проходим по всем клеткам доски.
map {
    # Копируем доску.
    @g = @F;
    # Устанавливаем чёрный камень в проверяемую позицию.
    $g[$_] = 'b';
    # Выводим, если в точке был пробел, и после установки на неё чёрного камня
    # на доске появляются захваченные белые камни.
    /d$/, print $`+ 1, $", $& + 1
      if $F[$_] =~ / / * grep { $g[$_] eq 'w' && c $_}
          0 .. $#g
  } 0 .. $#F

#!perl
@g = ( d .. n, map { /./g, '' } <> );

# Функция теперь получает позицию точки вместо пары координат.
sub n {
    my ( $i, $r ) = @_;
    # Вычищен хеш для хранения информации о проверенных точках,
    # теперь это помечается прямо на доске.
    map {
        do {
            $_ = 1 and $r = n( $i + 1 ) + n( $i - 1 ) + n( $i + 10 ) + n( $i - 10 ) == 1
                if /w/;
            $_ = $r = 1 and $0 = $i
                if / /
          } if /D/
    } $g[$i];
    $r
}
map {
    # Найдено новое решение для преобразования позиции точки в координаты
    printf "%s %sn", $0 =~ /./g
        if $g[$_] eq 'w' && n($_)
} 0 .. 99

#!perl -ln0aF//
# Активно используем флаги:
# -n добавляет «while () { … }» вокруг кода;
# -0 позволяет считать входные данные целиком, не разбивая на строки;
# -a включает автосплит, разбивая входную строку и помещая в @F;
# -F// заставляет -a разбивать строку посимвольно;
# -l автоматически добавляет перевод строки в print.

# Функция проверки «захваченности» точки
sub c {
    my $s = pop;
    # Считаем захваченной, если
    # позиция выходит за границы поля (отрицательная или содержит девятку),
    $s =~ /-|9/
      # или точка занята чёрным камнем,
      || $g[$s] eq 'b'
      # или точка занята белым камнем и нет незахваченных соседей.
      || $g[$s] =~ /w/ * !grep { $g[$s] = 'b'; !c( $s + $_ ) } 1, -1, 10, -10;
}
# Проходим по всем клеткам доски.
map {
    # Копируем доску.
    @g = @F;
    # Устанавливаем чёрный камень в проверяемую позицию.
    $g[$_] = 'b';
    # Выводим, если в точке был пробел, и после установки на неё чёрного камня
    # на доске появляются захваченные белые камни.
    /.$/, print $`+ 1, $", $& + 1
      if $F[$_] =~ / / * grep { $g[$_] eq 'w' && c $_}
          0 .. 89
} 0 .. 89

#!perl -ln0

# Оптимизированы циклы, в том числе за счёт использования флагов.
map {
    $i = $-[0] + 11; # Смещение позиции вместо добавления строки.
    {
        map {
            1 while s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s;
            /W((?<= .{10})|(?<= .)|(?=.{9} | ))/s
              || $i =~ /./ +
              print("$& $'") +
              last
          } "$`W$'" while /w/g
    }
} "$`x$'" while / /g

#!perl -ln0

# Последовательно заменяем каждый пробел на «x».
map {
    1 while $, =
        # Последовательно заменяем группы белых камней на g.
        # (Используя $, в качестве рабочей переменной, можем конкатенировать её
        # в регулярное выражение без смешения со следующим символом.)
        s=$,w=g=s
        # Формируем хитрое регулярное выражение для обработки соседних точек.
        ? '(g|(?=.g|..{9}g)|g.{9})K'
        # Если заменённых белых камней больше, чем соседствующих с ними пробелов,
        # то есть захваченные камни.
        : /g/ > /$, /s
          && map {
              # В @+ имеем позицию конца последнего совпадения в регэкспе /x/,
              # т. е. позицию текущей обрабатываемой пустой точки.
              # Складываем её с единицей (/x/) и приводим в числовой контекст,
              # получая -1 степень (E-1). Заменяя в полученной дроби «.» на « »,
              # получаем координаты для вывода.
              y!.! !;
              print;
              redo
          } /x/ + "@+E-1"
          # Если захваченных камней не нашли — заменяем помеченные белые камни
          # на чёрные и продолжаем.
          or y&g&b&
} "$`x$'" while / /g