Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

YAPC::EU::2013 Go Perl golf contest

by nobull (Friar)
on Aug 13, 2013 at 14:35 UTC ( #1049290=obfuscated: print w/replies, xml ) Need Help?? sponsors of YAPC::EU::2013 set this challenge based on the game of Go:
  1. Problems are given for a Go training board with the size of 9◊9.
  2. Black moves first.
  3. There are no stones already captured on the board.

Input: nine lines which represent the playing board are sent to STDIN. Lines consist of spaces (for vacant points on the board), "w" symbols (for white stones) and "b" symbols (black stones) and end with the new line symbol ("\n").

Output: сoordinates (row and column numbers separated with a space, counted from one) of points, a move to which results in the capture of white stones. Results must be sent to STDOUT, one point per line. Results must contain all the possible moves on the board which would lead to the capture of white stones. Points are to be output in the order of their position on the board (left to right, top to bottom).

This is my first attempt at Perl-golf and (because BooK wasn't here this year) I actually won with 205 characters. (Woo hoo!)

#!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}}}
Or with comments and whitespace
#!perl $b = ++$/ x 11 . <>; # $/='1' (not prese +nt in input). Slurp STDIN. # Prepend '11111111 +111' so top left is at 11. # Leave the "\n" in + to act as border and make # rows 10 so linear + pos is also row/col. for $i (9..99) { # Scan all possible + cells (including border). if( ($x=$b) =~ s/^(.{$i}) /$1x/s ) { # If cell is ' ' pl +ace 'x' in a copy of board. while( $x=~/w/g ) { # Consider each 'w' + in turn and $_ = "$`W$'"; # copy board high +ighing that 'w' as 'W'. 1 while # Until you run out +, s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s; # highlight a nei +ghbouring 'w'. /W((?<= .{10})|(?<= .)|(?=.{9} | ))/s # Find a 'W' neighb +ouring a ' '. || # If there is no su +ch peg we have captured. $i=~/./ + # Split row number +out of cell number. (print"$& $'\n") + # Print row and col +unm. last # Advance to next p +ossible cell. } } }

Improvements from the Monks welcome.

Replies are listed 'Best First'.
Re: YAPC::EU::2013 Go Perl golf contest
by nobull (Friar) on Aug 14, 2013 at 21:21 UTC
    I gave a lightning talk about this and heard that someone (falsely rumoured to be BooK) had managed 197, so I've pared this down to 184 by using map{} as suggested by Sergei Mozhaisky.
    #!perl $_=++$/x11 .<>;map{$i=$-[0];{map{1while s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s;/W((?<= .{10})|(?<= .)|(?=.{9 +} | ))/s||$i=~/./+print("$& $'\n")+last}"$`W$'"while/w/g}}"$`x$'"whil +e/ /g
    #!perl $_= ++$ / x11 . <>; map { $i = $-[0]; { map { 1 while s/w((?<=W.{10})|(?<=W.)|(?=.{9}W|W))/W/s; /W((?<= .{10})|(?<= .)|(?=.{9} | ))/s || $i=~/./ + print("$& $'\n") + last } "$`W$'" while/w/g } } "$`x$'" while/ /g


    Having stolen more ideas from Timur Nozadze I am now at 175

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

      Variable-length negative look-behind can be emulated using \K. The two regexes are almost identical, and can be abstracted in a variable. "@-" is shorter than "$-[0]". If using perl >= 5.14, /./ followed by "$& $'" can be replaced with s/./$& /r.

      All in all, that's 30 characters easily chipped off. Thereís still a lot of room for improvementóthis next is hurting my eyes. Iíll probably look at it some more another day.

      #!perl -ln0 $:='(.{9}|)\Kw|w(?=(.{9}|)'; map{$i="@-"+11;{map{1while s/W$:W)/W/s;/ \U$: )/s||print($i=~s/./$& /r)+next}"$`W$'"while/w/g}}"$ +`x$'"while/ /g
        Another 22 characters shaved off:
        #!perl -ln0 $:='((?=W|.{9}W)|(?<=W.)|(?<=W.{10}))';{1while s/w$:/W/s;/ $:/gs>//gs& +&print+("@-E-1"+1)=~y/./ /r;y/W/x/;s/w/W/&&redo}
        EDIT: Down to 109. Iím starting to like it, but we can likely get this under 100.
        #!perl -ln0 $,='((?=.(.{9})?g)|g(.{9})?\K)'until!s!$,w!g!s;$,=/$, /gs>//gs&&!map!y +!.! !>print,"@-e-1"+1;y&g& &&&redo
        EDIT2: While my first solution was correct, both solutions in this post have the same problem: if playing a single black stone captures multiple white groups, this move is printed multiple times. Hereís a 127 stroker that prints each move only once:
        #!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

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: obfuscated [id://1049290]
Approved by marto
Front-paged by Corion
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (3)
As of 2023-06-08 22:00 GMT
Find Nodes?
    Voting Booth?
    How often do you go to conferences?

    Results (35 votes). Check out past polls.