25
$\begingroup$

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]]]
Improve this question
$\endgroup$
1
  • 1
    $\begingroup$ +1 for a neat question and nice exposition of it. It will be interesting to see the answers from the wizards here... $\endgroup$ Commented Apr 23, 2014 at 8:21

4 Answers 4

Reset to default
15
$\begingroup$

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.

Improve this answer
$\endgroup$
8
  • $\begingroup$ I figured you'd chime in with CA! +1 $\endgroup$ Commented Apr 23, 2014 at 8:22
  • $\begingroup$ 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. $\endgroup$ Commented Apr 25, 2014 at 0:39
  • $\begingroup$ Ok, I fully understood your solution, and it's beautiful. I can see now how I can add diagonal and non-linear patterns, too. $\endgroup$ Commented Apr 27, 2014 at 0:34
  • $\begingroup$ @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. $\endgroup$ Commented Apr 27, 2014 at 0:39
  • $\begingroup$ @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? $\endgroup$ Commented Apr 27, 2014 at 0:47
9
$\begingroup$

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

Improve this answer
$\endgroup$
5
  • $\begingroup$ 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. $\endgroup$ Commented Apr 25, 2014 at 0:41
  • $\begingroup$ Is there a way to define new patterns easily, similar to my matchPattern below? $\endgroup$ Commented Apr 25, 2014 at 0:42
  • $\begingroup$ 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. $\endgroup$ Commented Apr 25, 2014 at 14:13
  • $\begingroup$ 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. $\endgroup$ Commented Apr 25, 2014 at 14:20
  • $\begingroup$ 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. $\endgroup$ Commented Apr 27, 2014 at 0:50
6
$\begingroup$

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

Improve this answer
$\endgroup$
4
$\begingroup$

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[] JavaApplicationSIM`main[{}]

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.

Improve this answer
$\endgroup$
3
  • 4
    $\begingroup$ 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. $\endgroup$ Commented Apr 23, 2014 at 13:28
  • 4
    $\begingroup$ 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. $\endgroup$ Commented Apr 23, 2014 at 17:33
  • 1
    $\begingroup$ @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. $\endgroup$ Commented Apr 25, 2014 at 0:43

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.