Skip to main content

programming - 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?


sample 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

straightforward solution


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

Answer



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.



Comments

Popular posts from this blog

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...