# Detecting patterns of black and white stones on a 2D board

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 *)
(* 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_}] :=
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]]]

-
+1 for a neat question and nice exposition of it. It will be interesting to see the answers from the wizards here... – ciao Apr 23 '14 at 8:21

One function comes to mind that already implements matching of multidimensonal rules: CellularAutomaton. Allow me to represent your board data like this:

board = SparseArray[
a /. h_[x_, y_] :> ({-y - 1, x + 1} -> h) /. {black -> \[FilledCircle],
white -> \[EmptyCircle]}, {7, 7}, " "];


For my example I shall show a generic 3x3 rule operation, but this can easily be extended. I know of no built-in way to handle the reflections and translations of your rules, so I will assist with:

variants[x_] :=
Join @@ Outer[# @ #2 @ x &, {Identity, Reverse, Reverse[#1, 2] &,
Reverse[#, {1, 2}] &}, {Identity, Transpose}]

expand[x : {_, _, _} -> v_] := variants[{{_, _, _}, x, {_, _, _}}] -> v // Thread


I now build the rules. The final rule merely keeps any element that is not at the center of a match unchanged.

rules =
Join[
expand[{\[EmptyCircle], \[EmptyCircle], \[FilledCircle]} -> "Q"],
expand[{\[EmptyCircle], \[FilledCircle], \[FilledCircle]} -> "R"],
{{{_, _, _}, {_, z_, _}, {_, _, _}} :> z}
];


As this looks in the Front End:

Finally I apply them to my board. This shows the original, and after a single transformation:

MatrixForm /@ CellularAutomaton[rules, board, 1]


You can see that any appearance of the patterns in any orthogonal orientation (but not a diagonal) is "marked" by a Q or R at the center accordingly.

This is certainly not a complete implementation of what you requested but I hope that it gives you a reasonable place to start. Another would be ListCorrelate and a kernel large enough to encompass your patters, filled perhaps with unique powers of two, thereby yielding a unique value for each possible "filling" of the overlay.

-
I figured you'd chime in with CA! +1 – ciao Apr 23 '14 at 8:22
Thanks Mr. Wizard. Although it doesn't fully answer my question, it is very inspirational. I will try to wrap my head around some of the new idioms that you are showing here over the weekend. – Victor K. Apr 25 '14 at 0:39
Ok, I fully understood your solution, and it's beautiful. I can see now how I can add diagonal and non-linear patterns, too. – Victor K. Apr 27 '14 at 0:34
@VictorK. Great! I'm not sure if it will perform well enough for your needs in this generalized rule form. If you can figure out how to convert your problem into a purely numeric CellularAutomaton that should be quite fast. – Mr.Wizard Apr 27 '14 at 0:39
@Mr.Wizard - do you know a good place to read more about CellularAutomaton? The built-in documentation is quite sparse - I don't fully understand what each of the different types of rule mean. I have Wolfram's NKS, but I've only read through first couple of chapters - is it described there? – Victor K. Apr 27 '14 at 0:47

This may be a bit un-mathematicaesque, but it turns out to be convenient to store the board as a flat vector:

(larger board for illustration)

 n = 12;
board0 = Flatten[ Table[0, {n^2}], 1];
v[icol_, jrow_] = icol + n (jrow - 1);


Now we can create lists of indices representing structures such as rows,columns, and diagonals. Here the function diag returns a list of the indices in the flat vector along each of the 8 directions in order away from a given row,column position:

 diag[icol_, jrow_, p_, q_] :=
Table[ (icol + p (k - 1) + n (jrow + q (k - 1) - 1)),
{k, Min[
((1 - n (p - 2)) (p + 1))/2 - p icol,
((1 - n (q - 2)) (q + 1))/2 - q jrow]}];
diag[ipos_, p_, q_] :=
diag[Mod[ipos - 1, n] + 1 , Floor[(ipos - 1)/n] + 1, p, q];

alldir = Cases[Tuples[{-1, 0, 1}, 2], Except[{0, 0}]];


manipulator illustrating how diag works

 Manipulate[
board = board0;
MapIndexed[ ((board[[#[[1]]]] =
Table[#[[2]], {Length[#[[1]]]}]) &@
{diag[col, row, Sequence @@ #], First@#2}) & , alldir ];
board[[v[col, row]]] = "X";
Partition[ board , n] // MatrixForm,
{{col, 3}, 1, n, 1}, {{row, 3}, 1, n, 1}]


now a random board, with 0-> empty, 1-> Red , -1->Black

 n = 6
board1 =Table[ RandomChoice[{-1, 0, 0, 1}], {n^2}];
GraphicsGrid[
Partition[
Graphics[{Switch[#, 1, Red, -1, Black, 0, White], Disk[{0, 0}],
Black, Circle[{0, 0}]}] & /@ board1 , n]]


now find all empty positions and search over all adjacent rows,columns,diagonals for the desired pattern:

 open = Flatten[Position[board1, 0]];
hits = Last@
Reap[ Function[{dir},
If[ MatchQ[board1[[d = diag[#, Sequence @@ dir]]] ,
{0, x_ /; x != 0, x_, y_ /; y != 0, ___} /; x != y],
Sow[d[[;; 4]]]]] /@ alldir & /@ open ];
GraphicsGrid[
Partition[
Graphics[{Switch[#, 1, Red, -1, Black, 0, White, 2, Green],
Disk[{0, 0}], Black, Circle[{0, 0}]}] & /@
MapIndexed[
If[Count[ (First@hits)[[;; , 1]] , First@#2] == 1, 2, #] &, board1] , n]]


just for fun a reversi simulation (pattern is different from Pente)

 h = 5; n = 2 h; board1 = Table[0, {n^2}];
board1[[{(h - 1) n + h, (h - 1) n + h + 1, h n + h, h n + h + 1}]] = {1, -1, -1, 1};
pb = GraphicsGrid[Partition[ Graphics[
{Switch[#, 1, Red, -1, Black, 0, White, 2, LightRed, -2 , Gray],
Disk[{0, 0}], Black, Circle[{0, 0}]}] & /@ # , n]] &;
up = 1; down = -1;
First@Last@Reap[
Sow[pb@board1 ];
While[0 < Length[
{up, down} = {down, up};
hits = Select[ Union@Flatten[Last@Reap[Function[{dir},
If[ MatchQ[
bb = board1[[d = diag[#, Sequence @@ dir]]] ,
{0, down .., up, ___}],
Sow[d[[;; First@First@Position[bb, up]]]]]] /@
alldir ]] &
/@ Flatten[Position[board1, 0]] , # != {} &]  ],
board1[[choice = RandomChoice[(Length /@ hits) -> hits]]] = 2 up;
Sow[gg = pb@board1 ];
board1[[choice]] = up]]


-
Thanks George - and +1 for a nice reversi visual. It looks like what you are suggesting here is somewhat similar to my solution below, but I would need to spend some time to truly understand what you are doing there. – Victor K. Apr 25 '14 at 0:41
Is there a way to define new patterns easily, similar to my matchPattern below? – Victor K. Apr 25 '14 at 0:42
this thing is the pattern: {0, x_ /; x != 0, x_, y_ /; y != 0, ___} /; x != y. zero, two nonzero elements the same, next element different and not zero followed by any number of arbitrary elements. – george2079 Apr 25 '14 at 14:13
In the reversi case we know whose turn it is (up) so the pattern to match is  {0, down .., up, ___}: zero, any number of the opponents color, one of "up" color then anything else. – george2079 Apr 25 '14 at 14:20
I had a hard time choosing between your solution and Mr.Wizard's, but I decided to go with his as it can be better generalized for a 2D (not linear) patterns, which strictly speaking was my original question, even though for my needs linear patterns will probably be enough. I'm still very grateful for you sharing your solution - I think I'm finally starting to appreciate the beauty of Reap and Sow. – Victor K. Apr 27 '14 at 0:50

Here is my own rough answer - it turns out that asking a question on SE helps clarifying one's thinking! I would still appreciate if some of the experts can weigh in.

First, we'll store the board as a square matrix of symbols B, W and ".":

m = Partition[RandomChoice[{B, W, "."}, 25], 5] // MatrixForm


$\left( \begin{array}{ccccc} W & . & B & B & W \\ W & . & B & . & . \\ W & B & W & B & W \\ W & B & . & W & . \\ W & . & . & . & W \\ \end{array} \right)$

Next, we'll generate a list of all possible segments, that is, horizontal, vertical or diagonal subsets of the matrix of length $k$. For example, the above matrix has 12 segments of length 5 - all rows, all columns and two big diagonals, and $10+10+4+4=28$ segments of length 4.

flatten1 := Flatten[#, 1] &

(* Give all segments of length k - horizontal, vertical and diagonal
- of a square matrix. Each segment is represented by a pair:
the elements themselves and their staring position and orientation in the matrix*)
segments[mat_, k_] := Module[{n = Length[mat]},
flatten1@Join[
(* vertical *)
Table[
{
mat[[i ;; i + k - 1, j]],
{i, j, vertical}
},
{i, n - k + 1}, {j, n}],
(* horizontal *)
Table[
{
mat[[i, j ;; j + k - 1]],
{i, j, horizontal}
},
{i, n}, {j, n - k + 1}],
(* diagonal SW *)
Table[
{
Table[mat[[i + x, j + x]], {x, 0, k - 1}],
{i, j, diagSW}
},
{i, n - k + 1}, {j, n - k + 1}],
(* diagonal NW *)
Table[
{
Table[mat[[i - x, j + x]], {x, 0, k - 1}], {
i, j, diagNW}},
{i, k, n}, {j, n - k + 1}]]]


For example,

segments[m[[1 ;; 3, 1 ;; 3]], 2] // Grid


returns

$\left( \begin{array}{cc} \{W,W\} & \{1,1,\text{vertical}\} \\ \{.,.\} & \{1,2,\text{vertical}\} \\ \{B,B\} & \{1,3,\text{vertical}\} \\ \{W,W\} & \{2,1,\text{vertical}\} \\ \{.,B\} & \{2,2,\text{vertical}\} \\ \{B,W\} & \{2,3,\text{vertical}\} \\ \{W,.\} & \{1,1,\text{horizontal}\} \\ \{.,B\} & \{1,2,\text{horizontal}\} \\ \{W,.\} & \{2,1,\text{horizontal}\} \\ \{.,B\} & \{2,2,\text{horizontal}\} \\ \{W,B\} & \{3,1,\text{horizontal}\} \\ \{B,W\} & \{3,2,\text{horizontal}\} \\ \{W,.\} & \{1,1,\text{diagSW}\} \\ \{.,B\} & \{1,2,\text{diagSW}\} \\ \{W,B\} & \{2,1,\text{diagSW}\} \\ \{.,W\} & \{2,2,\text{diagSW}\} \\ \{W,.\} & \{2,1,\text{diagNW}\} \\ \{.,B\} & \{2,2,\text{diagNW}\} \\ \{W,.\} & \{3,1,\text{diagNW}\} \\ \{B,B\} & \{3,2,\text{diagNW}\} \\ \end{array} \right)$

Finally, once we have all the segments, comparison to a pattern is easy - notice how in matchPattern, we generate all 4 patterns {B,W,W,"."}, {W,B,B,"."}, {".",W,W,B} and {".",B,B,W} from the pattern {B,W,W,"."} since our comparison is literal:

(* match a single pattern *)
matchPattern1[p_] :=
Function[mat, Select[segments[mat, Length[p]], #[[1]] == p &]];

(* match multiple patterns *)
matchPattern2[p_] := Function[mat, matchPattern1[#][mat] & /@ p];

(* match all variations of a pattern *)
matchPattern[p_] :=
Function[mat,
flatten1[matchPattern2[{p, Reverse[p], p /. {W -> B, B -> W},
Reverse[p /. {W -> B, B -> W}]}][mat]]]


Now we can easily define a function to select all killable pairs:

killablePair = matchPattern[{B, W, W, "."}];


and apply it to the above matrix

killablePair[m]


{{{".", B, B, W}, {1, 2, horizontal}}}

-

EDIT

Making this code runnable with Java reloader.

1. Load the Java reloader (run the code from that post. For Mac OS X, see the comments below the post for a link to the Mac version)

2. Compile the class:

-

JCompileLoad @

"package javaapplicationsim;

/**
* @author developer
*/
public class JavaApplicationSIM {

final byte E = 0;  // EDGE
final byte _ = 1;  // EMPTY CELL
final byte B = 2;  // BLACK
final byte W = 3;  // WHITE

byte [][] board = new byte[][] {
{ E, E, E, E, E, E, E, E, E, E },
{ E, _, _, _, _, _, _, _, _, E },
{ E, _, B, B, W, _, _, _, _, E },
{ E, _, _, _, W, W, B, B, _, E },
{ E, _, B, _, W, B, B, B, _, E },
{ E, _, B, _, _, B, _, _, _, E },
{ E, _, B, _, _, B, _, _, _, E },
{ E, _, W, B, W, W, W, W, _, E },
{ E, _, _, _, _, _, _, _, _, E },
{ E, E, E, E, E, E, E, E, E, E }
};

private void drawBoard() {
for( int row=0; row<board.length; row++ ) {
String ch = \"\";
for( int col=0; col<board[row].length; col++ ) {
switch( board [row] [col] ) {
case E : ch = \"+\"; break;
case _ : ch = \" \"; break;
case B : ch = \"B\"; break;
case W : ch = \"W\"; break;
}
System.out.print( ch );
}

System.out.println();
}
}

private void count( int dx, int dy, int row, int col, int endColor ) {

boolean done = false;
boolean reachedEndColor = false;

int x   = col;
int y   = row;
int len = 0;

do {
x = x + dx;
y = y + dy;

if( board [y] [x] == E ) {
// reached an edge, must end the traversal!
done = true;
}

if( board [y] [x] == _ ) {
// reached an empty cell
done = true;
}

if( board [y] [x] == endColor ) {
// reached the opposite side that has the same color
reachedEndColor = true;
}

if( !done && !reachedEndColor ) {
// the color of the current cell must be the color of the other player
// keep on with the search
len = len + 1;
}

} while( !done && !reachedEndColor );

if( reachedEndColor && len > 0 ) {
System.out.println( \"Len = \" + len + \" from pos (\" + row + \" , \" + col + \"), dir (\" + dy + \" , \" + dx + \")\" );
}
}

private void solve( byte endColor ) {
for( int row=1; row<=8; row++ ) {
for( int col=1; col<=8; col++ ) {
if( board [row] [col] == _ ) {
// the cell must be empty (since the new brick is supposed to be placed there!)

count( -1,  0, row, col, endColor );  // LEFT
count( -1, -1, row, col, endColor );  // LEFT + UP
count(  0, -1, row, col, endColor );  // UP
count(  1, -1, row, col, endColor );  // RIGHT + UP
count(  1,  0, row, col, endColor );  // RIGHT
count(  1,  1, row, col, endColor );  // RIGHT + DOWN
count(  0,  1, row, col, endColor );  // DOWN
count( -1,  1, row, col, endColor );  // LEFT  + DOWN
}
}
}
}

/**
* @param args the command line arguments
*/
public static void main( String [] args ) {
JavaApplicationSIM sim = new JavaApplicationSIM();
sim.drawBoard();
sim.solve( sim.B );
}
}"

1. Run the code as

ShowJavaConsole[]
JavaApplicationSIMmain[{}]


This program produces the following output (on the console):

(first it shows the board)

++++++++++
+        +
+ BBW    +
+   WWBB +
+ B WBBB +
+ B  B   +
+ B  B   +
+ WBWWWW +
+        +
++++++++++


Then the program tells all the positions that will qualify as a place to put the BLACK color.

Len = 2 from pos (1 , 3), dir (1 , 1)
Len = 1 from pos (2 , 5), dir (0 , -1)
Len = 1 from pos (2 , 5), dir (1 , 0)
Len = 2 from pos (3 , 3), dir (0 , 1)
Len = 1 from pos (3 , 3), dir (1 , 1)
Len = 1 from pos (4 , 3), dir (0 , 1)
Len = 1 from pos (7 , 1), dir (0 , 1)
Len = 4 from pos (7 , 8), dir (0 , -1)
Len = 1 from pos (8 , 2), dir (-1 , 0)
Len = 1 from pos (8 , 3), dir (-1 , 1)
Len = 1 from pos (8 , 5), dir (-1 , 0)
Len = 1 from pos (8 , 7), dir (-1 , -1)
`

One can transfer the result back to Mathematica from Java with a bit more work.

-
I am afraid this site is for Mathematica programming related questions and answers. Your answer is unfortunately written in Java and does not seem to be related to Mathematica, therefore I'm voting to close. – Sjoerd C. de Vries Apr 23 '14 at 13:28
Pellesatansfant, Leonid Shifrin has kindly edited this answer to salvage your effort by including a method to allow it to be run from Mathematica. However Sjoerd is entirely correct that answers on this site must focus on Mathematica the software, so please refrain from posting future answers in other languages. Nevertheless thank you for your effort on this one. – Mr.Wizard Apr 23 '14 at 17:33
@Pellesatansfant - thanks for the effort, but as the others have pointed out already, your solution is probably not very useful to me, for two reasons: 1) I want a Mathematica solution, and 2) Your solution doesn't really allow to define new patterns easily. – Victor K. Apr 25 '14 at 0:43