Download the raw code.
use v6;
use Test;
# borrowed from List::Utils
sub sliding-window-wrapped(@a, $n) is export(:DEFAULT) {
my $a-list = @a.iterator.list;
my @values;
gather {
while defined(my $a = $a-list.shift) {
@values.push($a);
@values.shift if +@values > $n;
take @values if +@values == $n;
}
for ^($n-1) {
@values.push(@a[$_]);
@values.shift if +@values > $n;
take @values if +@values == $n;
}
}
}
class Board {
has @.stones;
multi method new(Numeric $N) {
self.bless(*, :stones(Bool::True xx $N));
}
multi method new(Str $board) {
if $board ~~ /\d/ {
self.bless(*, :stones($board.split("-").map({ Bool::True xx +$_, Bool::False }).flat));
} else {
self.bless(*, :stones($board.comb(/ '#' | ' ' /).map({ $_ eq '#' })));
}
}
method Str {
"[" ~ @.stones.map({ $_ ?? '#' !! ' ' }).join ~ "]";
}
method classification-str {
self.runs().map(*.value).map({
when 5 { (2, 2) };
when 3 { 2 };
default { $_ };
}).flat.sort(-*).join('-');
}
method any-moves-available() {
[||] sliding-window-wrapped(@.stones, 2).flat.map(* && *);
}
method play($n) {
if @.stones[$n] && @.stones[($n + 1) % *] {
@.stones[$n] = Bool::False;
@.stones[($n + 1) % *] = Bool::False;
Bool::True;
} else {
Bool::False; # not a legal move
}
}
method play-available($n) {
if @.stones[$n] && @.stones[($n + 1) % *] {
Bool::True;
} else {
Bool::False;
}
}
method runs() {
my @runs;
my $starting-stone = 0;
my $stone-count = 0;
for @.stones.kv -> $i, $stone {
if !$stone && $stone-count > 0 {
@runs.push($starting-stone => $stone-count);
$stone-count = 0;
}
if $stone {
$starting-stone = $i unless $stone-count > 0;
$stone-count++;
}
}
if $stone-count > 0 {
if ?@runs && @runs[0].key == 0 {
@runs[0] = $starting-stone => @runs[0].value + $stone-count;
} else {
@runs.push($starting-stone => $stone-count);
}
}
@runs.grep(*.value > 1);
}
method sorted-runs() {
my @runs = self.runs;
my @longs = @runs.grep({ $_.value > 5 }).sort(-*.value);
my @fours = @runs.grep({ $_.value == 4 });
my @twos = @runs.grep({ $_.value ~~ 2..3 });
# a run of 5 is basically equivalent to two runs of 2,
# so register it that way to simplify cases
for @runs.grep({ $_.value == 5 }) -> $five {
@twos.push($five.key => 2, $five.key + 3 => 2);
}
my $twos = @twos;
my $fours = @fours;
my $longs = @longs;
$twos, $fours, $longs;
}
}
# ee eo oe oo
my %pattern = "" => ["doom", "2[0]", "4[1]", "4[0]"],
"6" => ["6[2]", "6[1]", "6[0]", "doom"],
"7" => ["7[0]", "doom", "7[1]", "4[1]"],
"8" => ["8[1]", "doom", "4[0]", "8[0]"],
"9" => ["doom", "9[0]", "4[1]", "9[1]"],
"10" => ["10[4]", "10[0]", "10[2]", "doom" ],
"11" => ["11[0]", "11[1]", "11[3]", "doom" ],
"12" => ["12[1]", "12[4]", "doom", "12[0]"],
"13" => ["13[3]", "13[2]", "doom", "13[0]"],
"14" => ["14[6]", "14[3]", "14[0]", "14[1]"],
"15" => ["doom", "15[5]", "15[0]", "4[0]" ],
"16" => ["16[5]", "16[4]", "16[1]", "16[2]"],
"16-14" => ["16[0]", "doom", "4[0]", "4[1]" ],
"17" => ["17[0]", "17[4]", "doom", "17[2]"],
"18" => ["18[1]", "18[7]", "doom", "18[3]"],
"19" => ["19[4]", "19[2]", "19[0]", "doom" ],
"20" => ["20[9]", "20[3]", "20[0]", "doom" ],
"21" => ["doom", "21[6]", "21[1]", "21[0]"],
"22" => ["22[5]", "doom", "4[0]", "22[0]"],
"23" => ["23[0]", "doom", "23[2]", "23[1]"],
"24" => ["24[1]", "24[0]", "24[2]", "doom" ],
"25" => ["doom", "25[0]", "25[3]", "4[0]" ],
"26" => ["26[2]", "26[1]", "doom", "26[0]"],
"27" => ["27[0]", "doom", "27[4]", "27[1]"],
"28" => ["28[1]", "doom", "28[0]", "28[4]"],
"29" => ["doom", "29[0]", "29[1]", "29[4]" ],
"30" => ["30[14]", "30[0]", "30[6]", "30[2]"],
"31" => ["31[0]", "31[1]", "31[4]", "31[3]"],
"32" => ["32[1]", "32[14]", "doom", "2[0]" ],
"33" => ["33[3]", "33[2]", "33[5]", "33[4]"],
"34" => ["34[16]", "34[3]", "34[0]", "34[4]"],
"35" => ["doom", "35[5]", "35[1]", "35[7]" ],
"36" => ["36[5]", "doom", "36[6]", "36[2]" ],
"37" => ["37[0]", "doom", "37[9]", "37[3]" ],
"38" => ["38[1]", "38[0]", "doom", "38[11]"],
"39" => ["doom", "39[0]", "39[5]", "4[0]" ],
"40" => ["40[2]", "40[1]", "40[0]", "doom" ],
"41" => ["41[0]", "doom", "41[1]", "41[7]" ],
"42" => ["42[1]", "doom", "4[0]", "42[0]" ],
;
my %fudge = "2[0]" => { 6 => "6[0]", 7 => "7[0]", 8 => "8[1]", 9 => "9[0]",
10 => "10[2]", 11 => "11[3]", 12 => "12[0]", 13 => "13[0]",
15 => "15[5]", 17 => "17[2]", 18 => "18[3]", 19 => "19[0]",
20 => "20[0]", 21 => "21[6]", 22 => "22[5]", 23 => "23[0]",
24 => "24[2]", 25 => "25[0]", 26 => "26[0]"},
"4[1]" => { 6 => "6[1]", 7 => "4[1]", 8 => "8[0]", 9 => "4[1]",
10 => "10[0]", 11 => "11[1]", 12 => "12[1]", 13 => "13[3]",
15 => "15[0]", 17 => "17[0]", 18 => "18[1]", 19 => "19[2]",
20 => "20[3]", 21 => "21[1]", 22 => "22[0]", 23 => "23[1]",
24 => "24[0]", 25 => "25[3]", 26 => "26[2]"},
"4[0]" => { 6 => "6[2]", 7 => "7[1]", 8 => "4[0]", 9 => "9[1]",
10 => "10[4]", 11 => "11[0]", 12 => "12[4]", 13 => "13[2]",
15 => "4[0]", 17 => "17[4]", 18 => "18[7]", 19 => "19[4]",
20 => "20[9]", 21 => "21[0]", 22 => "4[0]", 23 => "23[2]",
24 => "24[1]", 25 => "4[0]", 26 => "26[1]"};
my $special-case-limit = 26;
my $explicit-limit = 42;
sub fudge-pattern($pattern, @twos, @fours, @longs) {
my $closer-fudge = %fudge{$pattern};
@longs.map({ $closer-fudge{$_.value} // $pattern }).max(+*);
}
sub get-pattern(@twos, @fours, @longs) {
my $look-for = @longs.map( *.value ).join('-');
my $patterns;
if %pattern{$look-for}.defined {
$patterns = %pattern{$look-for};
} elsif ?@longs.grep({ $_.value <= $special-case-limit }) {
# special case 6-21
my @look-for = @longs.grep({ $_.value > $special-case-limit }).map( *.value );
@look-for.push(16) if +@longs.grep({ $_.value == 16 }) % 2 == 1;
@look-for.push(14) if +@longs.grep({ $_.value == 14 }) % 2 == 1;
$look-for = @look-for.join('-');
$patterns = %pattern{$look-for};
if $patterns.defined {
my $reverse = +@longs.grep( *.value == 6 | 10 | 11 | 12 | 13
| 17 | 18 | 19 | 20 | 24 | 26 ) % 2 == 1;
my $swap = +@longs.grep( *.value == 7 | 8 | 12 | 13 | 17 | 18 | 22 | 23 | 26 ) % 2 == 1;
$patterns .=reverse if $reverse;
$patterns := $patterns.map(-> $a, $b { $b, $a }).flat if $swap;
$patterns := $patterns.map({ fudge-pattern($_, @twos, @fours, @longs) });
} else {
return Any;
}
} else {
return Any;
}
$patterns[(+@fours %% 2 ?? 0 !! 2) + (+@twos %% 2 ?? 0 !! 1)];
}
sub is-sure-win-my-turn($board) {
my (@twos, @fours, @longs) := $board.sorted-runs;
my $move = get-pattern(@twos, @fours, @longs) // "doom";
$move ne "doom";
}
sub try-move($board, $move) {
my $new-board = Board.new(~$board);
$new-board.play($move);
my (@twos, @fours, @longs) := $new-board.sorted-runs;
get-pattern(@twos, @fours, @longs) // "don't know";
}
sub blind-search($board, @twos, @fours, @longs, :$verbose?) {
if ?@longs {
if @longs[0].value > 2 + $special-case-limit + $explicit-limit
|| (+@longs > 1) && @longs[1].value > $special-case-limit {
say "Carving out arbitrary null piece to get closer to analytical range" if $verbose;
(@longs[0].key + 21);
} else {
my %candidates;
for @longs.grep({ $_.value > $special-case-limit }) -> $long {
%candidates{$long.value} = $long;
}
my $maybe-move = @longs[0].key; # make sure we have a move of some sort ready
for %candidates.values.sort(*.value) -> $c {
for $c.key .. ($c.key + $c.value div 2) -> $move {
given try-move($board, $move) {
when "doom" {
say "This move ($move) should spell doom for our opponent" if $verbose;
return $move;
}
when "don't know" { $maybe-move = $move; } # we don't know if this is bad or not
default { } # this one is for sure bad, skip it
}
}
}
say "This move ($maybe-move) is not known to be bad for us" if $verbose;
$maybe-move;
}
} else {
say "Known bad situation" if $verbose;
(@fours[0] // @twos[0]).key;
}
}
sub find-move($board, :$verbose?) {
my (@twos, @fours, @longs) := $board.sorted-runs;
sub find-move-inner() {
my $move = get-pattern(@twos, @fours, @longs);
say :$move.perl if $verbose;
return $move unless $move.defined;
if $move ~~ m/(\d+) \[ (\d+) \]/ {
my $target-length = $0;
my $index = $1;
my $target-run;
given $target-length {
when 2 { $target-run = @twos[0]; }
when 4 { $target-run = @fours[0]; }
when * {
$target-run = @longs.first(*.value == $target-length)
// die "Unable to find $target-length";
}
}
$target-run.key + $index;
} else {
die "Trouble!" if $move ne "doom";
Any;
}
}
my $raw-move = find-move-inner();
if $raw-move.defined {
$raw-move % +$board.stones;
} else {
blind-search($board, @twos, @fours, @longs, :$verbose) % +$board.stones;
}
}
multi MAIN(:$verbose?) {
my $number-stones = +($*IN.get // 0);
my $first-player = $*IN.get // "";
unless $number-stones > 1 && $first-player eq "human" | "computer" {
say "aborted";
return;
}
my $board = Board.new($number-stones);
my $first-turn = Bool::True;
loop {
if !$first-turn || $first-player eq "computer" {
say $board if $verbose;
my $move = find-move($board, :$verbose);
my $second = ($move + 1) % +$board.stones;
say "computer takes $move,$second";
$board.play($move) || die "Computer failed to play a legal move";
}
if !$board.any-moves-available {
say "computer wins";
last;
}
say $board if $verbose;
say "human to move: " ~ $board.stones.pairs.grep(*.value).map(*.key).join(',');
my $human-move = prompt("");
# while !$human-move.match(rx/^\s* (\d+) \s* , \s* (\d+)/) {
# $human-move = prompt("unrecognized format, try again: ");
# }
$board.play(+$human-move) || die "Human failed to play a legal move";
if !$board.any-moves-available {
say "human wins";
last;
}
$first-turn = Bool::False;
}
}
multi MAIN($long-run where { $long-run ~~ /^ [\d+] ["-" \d+]* $/ }) {
my @patterns;
my $base-pattern = "[" ~ $long-run.split("-").map({ "#" x +$_ ~ " " }).join;
@patterns.push: $base-pattern ~ "]";
@patterns.push: $base-pattern ~ "## ]";
@patterns.push: $base-pattern ~ "#### ]";
@patterns.push: $base-pattern ~ "#### ## ]";
for @patterns -> $pattern {
my @promising = gather for ^($pattern.chars - 2) -> $i {
my $board = Board.new($pattern);
if $board.play($i) {
my (@twos, @fours, @longs) := $board.sorted-runs;
my $move = get-pattern(@twos, @fours, @longs);
if $move.defined {
take "$i" if $move eq "doom";
} else {
take "*{$i}";
}
}
}
say "{ $pattern }: " ~ (?@promising ?? @promising.join(", ") !! "No winning moves");
}
}
multi MAIN("run", $long-run) {
plan *;
my $pattern = "[" ~ $long-run.split("-").map({ "#" x +$_ ~ " " }).join;
my $board = Board.new($pattern);
my $name = "pattern " ~ $board.runs.map(*.value).join('-');
ok is-sure-win-my-turn($board), "is-sure-win-my-turn is right about $name";
say $board;
my $i = 1;
loop {
my $move = find-move($board, :verbose);
ok $board.play($move), "Move #{ $i++ } worked ($name)";
say "\n" ~ $board;
say "classification " ~ $board.classification-str;
last unless $board.any-moves-available;
$move = find-move($board, :verbose);
ok $board.play($move), "Move #{ $i++ } worked ($name)";
say "\n" ~ $board;
say "classification " ~ $board.classification-str;
ok $board.any-moves-available, "Board is not yet done ($name)";
last unless $board.any-moves-available; # whoops!
last if $i > +$board.stones; # something very wrong, bail out
}
nok $board.any-moves-available, "Board is done, first player won ($name)";
done;
}
multi MAIN("test") {
plan *;
for "[## # # ]", "[#### #### ## ]" -> $string {
my $board = Board.new($string);
isa_ok $board, Board, "Made a board object";
is +$board.stones, $string.chars - 2, "Board has right number of stones";
is ~$board, $string, "Board has correct pattern";
}
for "2", "6-2", "10-7-3-2" -> $string {
my $board = Board.new($string);
isa_ok $board, Board, "Made a board object";
is +$board.stones, ([+] $string.split('-').map(* + 1)),
"Board has right number of stones";
is +$board.stones.grep(* == Bool::False), +$string.split('-'),
"Board has correct number of false stones";
is $board.runs.map(*.value).join('-'), $string, "Matched $string";
}
{
my $board = Board.new("[ # ]");
nok $board.any-moves-available, "No moves available";
}
{
my $board = Board.new(4);
isa_ok $board, Board, "Made a board object";
is +$board.stones, 4, "Board has 4 stones";
ok (all $board.stones), "All stones are true";
ok $board.play(1), "Play 1 & 2";
nok (all $board.stones), "Not all stones are true";
ok $board.any-moves-available, "There is still a move available";
nok $board.play(1), "Can no longer play 1 & 2";
nok $board.play(0), "Can't play 0 & 1";
nok $board.play(2), "Can't play 2 & 3";
ok $board.stones[0], "Stone 0 still there";
nok $board.stones[1], "Stone 1 gone";
nok $board.stones[2], "Stone 2 gone";
ok $board.stones[3], "Stone 3 still there";
ok $board.play(3), "Play 3 & 0";
ok (none $board.stones), "No stones are true";
nok $board.any-moves-available, "There are no moves available";
}
{
my $board = Board.new(5);
isa_ok $board, Board, "Made a board object";
is +$board.stones, 5, "Board has 4 stones";
ok (all $board.stones), "All stones are true";
ok $board.play(1), "Play 1 & 2";
nok (all $board.stones), "Not all stones are true";
ok $board.any-moves-available, "There is still a move available";
nok $board.play(1), "Can no longer play 1 & 2";
nok $board.play(0), "Can't play 0 & 1";
nok $board.play(2), "Can't play 2 & 3";
ok $board.stones[0], "Stone 0 still there";
nok $board.stones[1], "Stone 1 gone";
nok $board.stones[2], "Stone 2 gone";
ok $board.stones[3], "Stone 3 still there";
ok $board.stones[4], "Stone 4 still there";
ok $board.play(3), "Play 3 & 4";
ok (one $board.stones), "One stone is true";
nok $board.any-moves-available, "There are no moves available";
}
{
my $board = Board.new(10);
is ~$board.runs, ~[0 => 10], "runs works for complete board";
ok $board.play(1), "Can play 1 & 2";
is ~$board.runs, ~[3 => 8], "runs works wraparound";
ok $board.play(5), "Can play 1 & 2";
is ~$board.runs, ~[7 => 4, 3 => 2], "runs works with two holes";
ok $board.play(8), "Can play 8 & 9";
is ~$board.runs, ~[3 => 2], "runs skips runs of length 1";
}
{
my $board = Board.new(11);
is ~$board.runs, ~[0 => 11], "runs works for complete board";
ok $board.play(0), "Can play 0 & 1";
is ~$board.runs, ~[2 => 9], "runs works with hole at beginning";
ok $board.play(9), "Can play 9 & 10";
is ~$board.runs, ~[2 => 7], "runs works with holes at beginning and end";
}
{
my $board = Board.new("[####### ## ## ]");
my (@twos, @fours, @longs) := $board.sorted-runs;
is +@longs, 1, "Found one long";
is @longs[0].value, 7, "and it has the correct length";
is +@fours, 0, "Found no fours";
is +@twos, 2, "Found two twos";
is @twos[0].value, 2, "and the first has the correct length";
is @twos[1].value, 2, "and the second has the correct length";
}
{
my $board = Board.new("[##### ### ####### #### ## ]");
my (@twos, @fours, @longs) := $board.sorted-runs;
is +@longs, 1, "Found one long";
is @longs[0].value, 7, "and it has the correct length";
is +@fours, 1, "Found one fours";
is +@fours.grep(*.value == 4), 1, "of correct length";
is +@twos, 4, "Found four twos";
is +@twos.grep(*.value == 2), 3, "with three length 2s";
is +@twos.grep(*.value == 3), 1, "and one length 3";
}
my @winning-patterns = "[##]",
"[###]",
"4",
"[#### ##]",
"4-2",
"4-2-2",
"4-2-2-2",
"5-2",
"6",
"6-2",
"6-4",
"6-6-2",
"6-6-4",
"6-6-4-2",
"6-6-6",
"6-6-6-2",
"6-6-6-4",
"6-6-6-6-2",
"6-6-6-6-4",
"6-6-6-6-4-2",
"7",
"7-4",
"7-4-2",
"7-6",
"7-6-2",
"7-6-4-2",
"7-6-6",
"7-6-6-4",
"7-6-6-4-2",
"7-6-6-6",
"7-6-6-6-2",
"7-6-6-6-4-2",
"7-7-2",
"7-7-4",
"7-7-4-2",
"8",
"8-4",
"8-4-2",
"8-6",
"8-6-2",
"8-6-4-2",
"8-7-2",
"8-7-4",
"8-7-4-2",
"8-8-2",
"8-8-4",
"8-8-4-2",
"9-2",
"9-4",
"9-4-2",
"9-6",
"9-6-2",
"9-6-4",
"9-7",
"9-7-4",
"9-7-4-2",
"9-8",
"9-8-4",
"9-8-4-2",
"9-9-2",
"9-9-4",
"9-9-4-2",
"10",
"10-2",
"10-4",
"10-6-2",
"10-6-4",
"10-6-4-2",
"10-7",
"10-7-2",
"10-7-4-2",
"10-8",
"10-8-2",
"10-8-4-2",
"10-9",
"10-9-2",
"10-9-4",
"10-10-2",
"10-10-4",
"10-10-4-2",
"9-9-9-2",
"9-9-9-4",
"9-9-9-4-2",
"10-9-8-7-6-2",
"10-9-8-7-6-4",
"10-9-8-7-6-4-2",
"15-13-12-2",
"15-13-12-4",
"15-13-12-4-2",
"14-14-2",
"14-14-4",
"14-14-4-2",
"14-14-14",
"14-14-14-2",
"14-14-14-4",
"14-14-14-4-2",
"11", "11-2", "11-4",
"11-7", "11-7-2", "11-7-4-2",
"12", "12-2", , "12-4-2",
"13", "13-2", , "13-4-2",
"14", "14-2", "14-4", "14-4-2",
"15-2", "15-4", "15-4-2",
"16", "16-2", "16-4", "16-4-2",
"17", "17-2", "17-4-2",
"18", "18-2", "18-4-2",
"19", "19-2", "19-4",
"20", "20-2", "20-4",
"21-2", "21-4", "21-4-2",
"22", "22-4", "22-4-2",
"23", "23-4", "23-4-2",
"25-2", "25-4", "25-4-2",
"26", "26-2", "26-4-2",
"27", "27-4", "27-4-2",
"28", "28-4", "28-4-2",
"29-2", "29-4", "29-4-2",
"30", "30-2", "30-4", "30-4-2",
"31", "31-2", "31-4", "31-4-2",
"32", "32-2", "32-4-2",
"33", "33-2", "33-4", "33-4-2",
"34", "34-2", "34-4", "34-4-2",
"35-2", "35-4", "35-4-2",
"36", "36-4", "36-4-2",
"37", "37-4", "37-4-2",
"38", "38-2", "38-4-2",
"39-2", "39-4", "39-4-2",
"40", "40-2", "40-4",
"41", "41-4", "41-4-2",
"42", "42-4", "42-4-2",
"2-2-2",
"4-4-2",
"4-4-2-2-2",
"5-4",
"5-4-2",
"5-4-2-2",
"4-4-4",
"4-4-4-2",
"4-4-4-2-2",
"4-4-4-2-2-2",
"4-4-4-4-2",
"4-4-4-4-2-2-2",
"4-4-4-4-4",
"4-4-4-4-4-2",
"4-4-4-4-4-2-2",
"4-4-4-4-4-4-2",
;
for @winning-patterns -> $pattern {
my $board = Board.new($pattern);
my $name = "pattern " ~ $board.runs.map(*.value).join('-');
ok is-sure-win-my-turn($board), "is-sure-win-my-turn is right about $name";
my $i = 1;
loop {
my $move = find-move($board);
ok $board.play($move), "Move #{ $i++ } worked ($name)";
# say $board;
last unless $board.any-moves-available;
$move = find-move($board);
ok $board.play($move), "Move #{ $i++ } worked ($name)";
ok $board.any-moves-available, "Board is not yet done ($name)";
last unless $board.any-moves-available; # whoops!
last if $i > +$board.stones; # something very wrong, bail out
}
nok $board.any-moves-available, "Board is done, first player won ($name)";
}
my @losing-patterns = "2-2",
"3-2",
"4-4",
"5",
"6-4-2",
"6-6",
"6-6-6-4-2",
"6-6-6-6",
"7-2",
"7-6-4",
"7-6-6-2",
"7-6-6-6-4",
"7-7",
"8-2",
"8-6-4",
"8-7",
"8-8",
"9",
"9-6-4-2",
"9-7-2",
"9-8-2",
"9-9",
"10-4-2",
"10-6",
"10-7-4",
"10-8-4",
"10-9-4-2",
"10-10",
"9-9-9",
"11-4-2",
"11-7-4",
"12-4",
"13-4",
"15",
"17-4",
"18-4",
"19-4-2",
"20-4-2",
"21",
"22-2",
"23-2",
"10-9-8-7-6",
"15-13-12",
"14-14",
"35",
"36-2",
"37-2",
"38-4",
"39",
"40-4-2",
"41-2",
"42-2",
;
for @losing-patterns -> $pattern {
my $board = Board.new($pattern);
my $name = "pattern " ~ $board.runs.map(*.value).join('-');
nok is-sure-win-my-turn($board), "is-sure-win-my-turn is right about $name";
}
# Test a few big boards, just to make sure we do something instead of crashing
for "100", "101", "102", "103", "100-6-6-4-4-2" -> $pattern
{
my $board = Board.new($pattern);
my $move = find-move($board);
ok $board.play($move), "We found a working move! ($pattern)";
}
done;
}
We note a number of changes compared to the previous version.
The is-sure-win-my-turn routine has been
refactored into something with much less indentation.
Instead, much of the special-casing in the code has been folded into the two
impressive data structures %pattern and %fudge. Not much is detailed about
them, but it is clear that they form the core in determining which moves
are to be preferred/avoided, and which ones spell certain doom for the
opponent. (Fittingly, the %pattern table is filled with "doom" strings.)
The header comment on the %pattern table
# ee eo oe oo
refers to even/odd numbers of runs of two and four stones, respectively. These play a special role in the evaluation of the position, no doubt because they are easy to understand and analyze. (They are so desirable that runs of three and five stones are retro-fitted onto runs of two stones.)
The patterns go through a process of reversing, swapping, and fudging on lines 213-215. Just the names make me crack up; it sounds like something out of STD.pm6.
There are various signs of this version not being polished. For example, the
routine fudge-pattern takes four parameters, but only uses the first one.
There's a never-reached statement Any; on line 296.
There's a new notation describing a game position with numbers and
dashes, along with the old one that used # signs for the individual stones.
It's an improvement, even though the solution still doesn't go the whole
way.
This algorithm plays really well. It doesn't make a mistake (that I've
discovered) until at $N = 56. Would still be an interesting exercise to
pit it against a perfect player.
In a way, this piece of code is my favorite because of the sheer amount of toil that must have gone into it. I... wow. It's not nearly the most elegant of solutions, but it's a labour of love. Hire this programmer!