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