I'm writing a program to play a game of Pente, and I'm struggling with the following question:
What's the best way to detect patterns on a two-dimensional board?
For example, in Pente a pair of neighboring stones of the same color can be captured when they are flanked from both sides by an opponent; how can we find all the stones that can be captured with the next move for the following board?
Below I show one possible straightforward solution, but with a defect: it's hard to extend it for other interesting patterns, i.e. three stones of the same color in a row surrounded by empty spaces, or four stones of the same color in a row which are flanked from one side but open from another, etc.
I'm wondering whether there is a way to define a DSL for detecting 2-dimensional structures like that on a board - sort of a 2D pattern matching.
P.S. I would also appreciate any advice on how to simplify the code below and make it more idiomatic - for example, I don't really like the way how sortStones is defined.
Straightforward solution
Here is one way to solve this problem (see below for graphics primitives to generate and display random boards):
- Enumerate all subsets of 3 stones from the board above
- Select those that form an AABE or ABBE pattern, where E denotes an unoccupied space
Lets store the board as a list of black and white stones,
a = {black[2, 1], black[4, 3], black[2, 5], black[4, 2], black[5, 3],
black[1, 2], black[1, 3], black[5, 4], black[1, 5], white[3, 1],
white[4, 1], white[4, 4], white[3, 5], white[3, 4], white[5, 1],
white[5, 2], white[3, 3], white[1, 1]}
First, we define isTriple which checks whether three stones sorted by their x and y coordinates are in the same row next to each other and follow an ABB or AAB pattern:
isTriple[{a_, b_, c_}] := And[
(* A A B or A B B *)
Head[a] != Head[c] /. {black -> 1, white -> 0},
(* x and y coordinates are equally spaced *)
a[[1]] - b[[1]] == b[[1]] - c[[1]],
a[[2]] - b[[2]] == b[[2]] - c[[2]],
(* and are next to each other *)
Abs[a[[1]] - b[[1]]] <= 1,
Abs[a[[2]] - b[[2]]] <= 1]
Next, we determine the coordinates and the color of the stone that will kill the pair:
killerStone[{a_, b_, c_}] :=
If[Head[a] == Head[b] /. {black -> 1, white -> 0},
Head[c][2 a[[1]] - b[[1]], 2 a[[2]] - b[[2]]],
Head[a][2 c[[1]] - b[[1]], 2 c[[2]] - b[[2]]]]
Finally, we only select those triples where killer stone's space is not already occupied:
sortStones[l_] :=
Sort[l, OrderedQ[{#1, #2} /. {black -> List, white -> List}] &]
triplesToKill[board_] := Module[
{triples = Select[sortStones /@ Subsets[board, {3}], isTriple]},
Select[triples,
Block[
{ks = killerStone[#]},
FreeQ[board, _[ks[[1]], ks[[2]]]]] &]]
displayBoard[a, #] & /@ triplesToKill[a] //
Partition[#, 3, 3, {1, 1}, {}] & // GraphicsGrid
Graphics primitives
randomPoints[n_] := RandomSample[Block[{nn = Ceiling[Sqrt[n]]},
Flatten[Table[{i, j}, {i, 1, nn}, {j, 1, nn}], 1]], n];
(* n is number of moves = 2 * number of points *)
randomBoard[n_] := Module[
{points = randomPoints[2 n]},
Join[
Take[points, n] /. {x_, y_} -> black[x, y],
Take[points, -n] /. {x_, y_} -> white[x, y]
]]
grid[minX_, minY_, maxX_, maxY_] :=
Line[Join[
Table[{{minX - 1.5, y}, {maxX + 1.5, y}}, {y, minY - 1.5, maxY + 1.5,
1}],
Table[{{x, minY - 1.5}, {x, maxY + 1.5}}, {x, minX - 1.5, maxX + 1.5,
1}]]];
displayBoard[board_] := Module[
{minX = Min[First /@ board], maxX = Max[First /@ board],
minY = Min[#[[2]] & /@ board], maxY = Max[#[[2]] & /@ board], n},
Graphics[{
grid[minX, minY, maxX, maxY],
board /. {
black[n__] -> {Black, Disk[{n}, .4]},
white[n__] -> {Thick, Circle[{n}, .4], White, Disk[{n}, .4]}
}}, ImageSize -> Small, Frame -> True]];
displayBoard[board_, points_] := Show[
displayBoard[board],
Graphics[
Map[{Red, Disk[{#[[1]], #[[2]]}, .2]} &, points]]]
