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

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 -> ●, white -> ○}, {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_, y_] := 
  Union @@ Outer[
    #@{y, x, y} ~Reverse~ #2 &,
    {Identity, Transpose},
    {{}, 1, 2, {1, 2}},
    1
  ]

expand[h_[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 /@ {
   {○, ○, ●}  -> "Q",
   {○, ●, ●}  -> "R",
   {_, z_, _} :>  z
 };

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

MatrixForm /@ CellularAutomaton[rules, board, 1]

enter image description here

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.


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}]

enter image description here

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]]

enter image description here

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]]

enter image description here

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]]

enter image description here


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}}}