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

от автора

С 12-го по 14-е августа в Киеве прошла очередная конференция perl-разработчиков YAPC::Europe 2013. Расширяющие сознание доклады, инсайдерская информация от разработчиков Perl 5 и Perl 6, живые легенды из мира Perl (включая самого Ларри Уолла!), речной круиз и замечательное общение в пабах кулуарах — всё было. Мероприятие заслуживает самой высокой оценки, а организаторы и докладчики (да и все остальные участники конференции) — всяческих похвал и благодарностей.

Однако, общеизвестно, что кроме обычных человеческих радостей perl-программисты склонны к развлечениями особенным, нормальным «хомо сапиенсам» не всегда понятным и близким.

Итак, как мы устроили Perl Golf на YAPC, и что из этого вышло.

Компания REG.RU поддержала конференцию в качестве спонсора. Наши ребята на стенде и в залах не скупясь раздавали замечательные футболки, полезную информацию о компании, улыбки и позитивную атмосферу, а кроме того ещё и провели конкурс на «самого сильного Perl-программиста» (отчёт со всеми подробностями и фотографиями на сайте REG.RU).

REG.RU на YAPC::Europe 2013

Но, конечно, остановиться на этом мы не могли. «Perl-мероприятию — perl-активности, и никак иначе!» — сказали мы себе, а потом начали думать, что же это, собственно, означает?

Что такое Perl Golf?

В общем и целом, Perl Golf — это соревнование по программированию (естественно, на Perl, хотя есть попытки «гольфить» и на других языках), в котором побеждает самая короткая программа, корректно решающая поставленную задачу. При этом не допускается использование каких-либо дополнительных модулей и внешних инструментов. Развлечение это — одно из любимых в среде perl-программистов, наряду с JAPH, обфускацией, code poetry и иными захватывающими, хотя, возможно, и не всегда практичными, занятиями. Кроме того, Perl Golf имеет абсолютно чёткие критерии оценки (минимальное количество символов в программе), так что в качестве конкурсного формата подходит идеально.

Опытных гольферов в коллективе не оказалось, так что пришлось осваивать ремесло практически с нуля. И, надо сказать, несмотря на внешнюю экзотичность (и даже некоторую ужасающесть с точки зрения любого программиста, понимающего, как должен выглядеть нормальный код), Гольф оказался занятием интересным и полезным, помогающим как изучить и понять глубокие и неочевидные особенности и возможности языка, так и потренировать способности чёткой и лаконичной формулировки задачи и её решения. В результате долгих раздумий и творческих мук родилась следующая история.

Легенда

Вы — сын знатного японского вельможи периода Эдо. Вы всегда мечтали стать программистом, но фамильные традиции оказались сильней — вас отдали в обучение мастеру Го. После небольшого теоретического введения мастер стал задавать вам задачки на захват камней.

Задачи несложные, однако, очевидно, что никаких способностей к Го у вас нет. К тому же, за каждую неправильно решённую задачку мастер больно лупит вас бамбуковым шестом, да ещё и заставляет ужинать, пользуясь только одной палочкой. Устав от побоев и хронического недоедания, вы решаете написать программу, которая будет решать задачи за вас. А поскольку бумага в период Эдо — штука дорогая, программа должна быть максимально короткой.

Основы игры Го

Го — древнейшая настольная стратегическая игра, появившаяся в Китае несколько тысяч лет назад и пережившая расцвет в Японии. В игре участвуют два игрока, по очереди располагающие чёрные и белые камни на точках пересечения сетки доски. Камень (или группа камней) считается захваченным и снимается с доски, если он со всех сторон окружён камнями противника. Например, на следующих диаграммах белые камни («w») или группы камней будут сняты с доски, если чёрные («b») сделают ход в точку, обозначенную «x»:

Условия и ограничения

  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.

Условие задачи и набор тестов для проверки были опубликованы на contest.reg.ru. Прохождение тестов считалось критерием корректности решения. Однако, уже после проведения конкурса участниками были предложено несколько дополнительных изощрённых тесткейсов, на которых споткнулись некоторые решения. Так что приведённые решения, если они не проходят дополнительные тесткейсы, помечаются отдельно.

Несмотря на активную профессиональную и социальную жизнь участников в течение всех дней (а также вечеров и ночей) конференции, мы получили несколько очень интересных решений, которые я и привожу далее с собственными аннотациями (со скидкой на степень моего понимания, ведь это всё-таки Гольф).

Конкурсные решения

205 символов — Brian McCauley

Победитель конкурса Perl Golf от REG.RUПобедитель конкурса предложил решение с подсвечиванием групп смежных камней и «обегающими» регулярными выражениями для проверки соседних точек (издревле бытует поверье, что только решение на регэкспах и может выиграть Perl Golf). Кроме того, использован появляющийся во многих решениях трюк с добавлением к входным данным дополнительной начальной строки, за счёт чего последовательная позиция точки на доске превращается в сочетание её координат (номера строки и номера столбца).

#!perl $b=++$/x11 .<>;for$i(9..99){if(($x=$b)=~s/^(.{$i}) /$1x/s){while($x=~/w/g){$_="$`W$'";1while s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s;/W((?<= .{10})|(?<= .)|(?=.{9} | ))/s||$i=~/./+(print"$& $'\n")+last}}} 

Аннотация

#!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;         }     } } 

Брайан опубликовал своё решение и собственную аннотацию к нему на PerlMonks. Кроме того, он сделал доклад с описанием этого решения в блоке лайтнингов.

За победу в конкурсе Брайан получил замечательный комплект для мини-гольфа, так что скука на рабочем месте ему теперь не грозит.

212 символов — Сергей Можайский (не проходит дополнительные тесткейсы)

Решение с рекурсивным обходом соседних точек и хранением информации о проверенных точках, чтобы избежать бесконечной рекурсии.

#!perl @g=(d..n,map{/./g,''}<>);sub n{my($i,$j,$r)=@_;map{$_=1and map{$r=n($i,$j+1)+n($i,$j-1)+n($i+1,$j)+n($i-1,$j)==1if/w/;$r=1and$0="$i $j\n"if/ /}$g["$i$j"]if!$_}$s{"$i$j"};$r}map{print$0if$g[$_]eq'w'&&n(/./g)}0..99 

Аннотация

#!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 $j\n" if / /         } $g["$i$j"] if !$_     } $s{"$i$j"};     # Возвращаем результат проверки     $r } # Проходим по всем точкам доски. map {     # Если в точке стоит белый камень, ищем возможность его захвата     # и выводим координаты найденной точки.     print $0       if $g[$_] eq 'w' && n(/./g) } 0 .. 99 

К сожалению, на дополнительных тестах решение имеет ложные срабатывания.

279 символов — Николай Шуляковский

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

#!/usr/bin/perl while(<>){tr/ wb\n/2133/;$str.=$_.'3'}@m=split//,('3'x12).$str;for(@m){%l=();$r=1;z($i);$o{$w[0]}=1if/1/&&$r&&(@w=%l)==2;$i++}printf"%d %d$/",$_/11,$_%11for sort keys%o;sub z{my$c=$_[0];for(qw/11 1 -11 -1/){$x=$c+$_;$n=$m[$x];$l{$x}=1if$n==2;if($n==1){z($x)if!/-/;$r=0if$i>$x}}} 

Аннотация

#!/usr/bin/perl while (<>) {                        # Считываем входные данные,     tr/ wb\n/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       # Обнуляем флаг, если точка позади                                     # изначально проверяемой точки                                     # (чтобы исключить повторы)         }     } } 

На дополнительных тесткейсах пойман довольно показательный баг: когда есть «захватывающие» позиции в последней линии поля (позиция в массиве 100 и больше), они попадают в вывод перед позициями, идущими на доске раньше. Вызвано это тем, что для сортировки результатов используется sort, а он по умолчанию работает в режиме строкового сравнения, т. е. «100» будет меньше, чем «99».

370 символов — Mikalai Liohenki + Denis Shirokov

Другая вариация решения с рекурсией. Здесь появляется ещё один часто используемый трюк: для проверки каждой точки делается копия доски, в неё устанавливается чёрный камень, и проверяется, есть ли после этого на доске захваченные белые камни.

#!perl $s='b'x12; while(<>){s/\n/bb/;s/ /0/g;$s.=$_;}$s.='b'x10;@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 %d\n",$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 # Считываем входные данные, замыкая их в рамку из чёрных камней. # Пробелы заменяем на 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 %d\n", $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; } 

390 символов — Dmitri L.

Очередное рекурсивное решение со специфическим агрегированием результата проверки соседей в виде счётчика.

#!perl push@t,split//,'b'x11;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){print"$r $c\n";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';$k+=2if$t[$_]eq'b'}$e?$k>7?$e:0:$k} 

Аннотация

#!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 $c\n"; # Выводим координаты                     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; } 

404 символа — Philippe Bruhat (BooK)

Не самое короткое, но, пожалуй, самое алгоритмически сложное, и одно из самых запутанных и трудных для разбора решений, так что не ждите полной ясности от моей аннотации.

#!perl #!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 

Аннотация

#!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
9×9 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. 🙂

500 символов — Savio PImatteo

И ещё одно рекурсивное решение, сравнивающее количество «несвободных» (чёрных или захваченных белых) камней на доске до и после установки чёрного камня в каждую пустую клетку.

#!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);return 0 if $c eq ' '||!$d&& $c ne 'w';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);}my$y='b'x11;while(<>){$y.="b$_";}$y=~s/\n/b/g;$y.='b'x11;$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 $x\n";}}$i++;} 

Аннотация

#!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 $x\n";         }     }     $i++; } 

581 символ — Dimitry Ivanov

Решение, очень близкое к предыдущему от Savio Pimatteo.

#!perl eval{ $a->[10]=$a->[0]=[('b')x11]; while(<STDIN>){chomp;@{$a->[++$i]}=('b',(split''),'b');last if $i>=9} sub f { my($x,$y)=@_; return $o[$j] if $n->[$x][$y]; 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); 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 $y\n" if $t<p; $a->[$x][$y]=' '; }} } 

Аннотация

#!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 $y\n" if $t < p;   # Выводим координаты точки, если после                                          # её проверки стало больше двоек                                          # (т. е. были захвачены новые камни).             $a->[$x][$y] = ' ';          # Убираем поставленный камень.         }     } } 

Внеконкурсные решения

Было бы странно устраивать конкурс и не иметь решения конкурсной задачи. Так что вот решение от организатора, то есть меня:

192 символа — Тимур Нозадзе

Прямолинейное рекурсивное решение. Неплохой результат достигнут за счёт плотной минимизации и избавления от всего лишнего, экономии на разборе входных данных с помощью флагов и достаточно эффективному трюку для перевода позиции точки в координаты с помощью регэкспа и специальных переменных.

#!perl -ln0aF// 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,$",$&+1if$F[$_]=~/ /*grep{$g[$_]eq'w'&&c$_}0..$#g}0..$#F 

Аннотация

#!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 

Несмотря на алгоритмическую простоту решения, на удивление много лишнего можно удалить из кода, если сконцентрироваться на сути задачи, а не плодить новые переменые и дублировать куски кода щедрой рукой, как мы это зачастую делаем. Так что Гольф заставляет сосредоточиться не просто на уменьшении размера кода, но и на более глубоком и очищенном от всего наносного понимании задачи и её решения.

Фактически, за время конкурса этот результат (192 символа) побит не был. Однако, на этом всё не закончилось, настало время коллабораций и обмена опытом.

197 символов — Сергей Можайский (не проходит дополнительный тесткейс)

Сергей улучшил своё решение, избавившись от промежуточной переменной и придумав новый вариант для вывода координат.

#!perl @g=(d..n,map{/./g,''}<>);sub n{my($i,$r)=@_;map{do{$_=1and$r=n($i+1)+n($i-1)+n($i+10)+n($i-10)==1if/w/;$_=$r=1and$0=$i if/ /}if/\D/}$g[$i];$r}map{printf"%s %s\n",$0=~/./g if$g[$_]eq'w'&&n($_)}0..99 

Аннотация

#!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 %s\n", $0 =~ /./g         if $g[$_] eq 'w' && n($_) } 0 .. 99 

189 символов — Тимур Нозадзе

Моё решение сократилось на пару символов благодаря замечаниям Брайана: получение размера массивов через $# было заменено на числовую константу 89, а регулярное выражение /\d$/ — на /.$/

#!perl -ln0aF// 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,$",$&+1if$F[$_]=~/ /*grep{$g[$_]eq'w'&&c$_}0..89}0..89 

Аннотация

#!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 

Принципиальных улучшений в этом подходе уже вряд ли стоит ожидать.

А дальше мы стали свидетелями битвы титанов на Perlmonks.

175 символов — Brian McCauley

Брайан серьёзно улучшил свой результат, воспользовавшись советом Сергея и некоторыми идеями из моего решения.

#!perl -ln0 map{$i=$-[0]+11;{map{1while 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  # Оптимизированы циклы, в том числе за счёт использования флагов. 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 
127 символов — Grimy

Пользователь Grimy с PerlMonks отолкнулся от идеи Брайана и довёл вариант с регэкспами до совершенно фантастического результата в 127 символов!

#!perl -ln0 map{1while$,=s=$,w=g=s?'(g|(?=.g|..{9}g)|g.{9})\K':/g/>/$, /s&&map{y!.! !;print;redo}/x/+"@+E-1"or y&g&b&}"$`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 

Сказать по правде, это решение для меня всё ещё сохраняет некоторый элемент мистики, но, надеюсь, моя аннотация не слишком далека от правды.

Что ж, распространённое убеждение в непобедимости решений на регэкспах полностью себя оправдало. Это потрясающий результат, и побить его будет трудно. Однако, зная невероятную смелость и боевые качества хабражителей, мы предлагаем попробовать свои силы. Каждый, кто предложит решение лучше (т. е. короче), чем текущий лидер (127 символов), получит в подарок от компании REG.RU домен в зонах .ru или.рф и VPS по любому тарифу на срок до 6 месяцев! Решения принимаются на contest@reg.ru. Принимаются только решения, успешно проходящие обновлённый набор тестов. Дерзайте!

ссылка на оригинал статьи http://habrahabr.ru/company/regru/blog/191704/


Комментарии

Добавить комментарий

Ваш адрес email не будет опубликован. Обязательные поля помечены *