Detecting patterns of black and white stones on a 2D board - Mathematica Stack Exchange most recent 30 from mathematica.stackexchange.com 2019-11-18T09:13:51Z https://mathematica.stackexchange.com/feeds/question/46631 https://creativecommons.org/licenses/by-sa/4.0/rdf https://mathematica.stackexchange.com/q/46631 25 Detecting patterns of black and white stones on a 2D board Victor K. https://mathematica.stackexchange.com/users/1351 2014-04-23T03:08:32Z 2017-02-21T17:42:53Z <p>I'm writing a program to play a game of <a href="http://en.wikipedia.org/wiki/Pente" rel="noreferrer">Pente</a>, and I'm struggling with the following question:</p> <blockquote> <p>What's the best way to detect patterns on a two-dimensional board?</p> </blockquote> <p>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?</p> <p><img src="https://i.stack.imgur.com/cV3Gb.png" alt="sample board"></p> <p>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.</p> <blockquote> <p>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 <em>2D pattern matching</em>.</p> </blockquote> <p>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 <code>sortStones</code> is defined.</p> <h2>Straightforward solution</h2> <p>Here is one way to solve this problem (see below for graphics primitives to generate and display random boards):</p> <ul> <li>Enumerate all subsets of 3 stones from the board above</li> <li>Select those that form an <em>AABE</em> or <em>ABBE</em> pattern, where E denotes an unoccupied space</li> </ul> <p>Lets store the board as a list of black and white stones,</p> <pre><code>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]} </code></pre> <p>First, we define <code>isTriple</code> 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:</p> <pre><code>isTriple[{a_, b_, c_}] := And[ (* A A B or A B B *) Head[a] != Head[c] /. {black -&gt; 1, white -&gt; 0}, (* x and y coordinates are equally spaced *) a[] - b[] == b[] - c[], a[] - b[] == b[] - c[], (* and are next to each other *) Abs[a[] - b[]] &lt;= 1, Abs[a[] - b[]] &lt;= 1] </code></pre> <p>Next, we determine the coordinates and the color of the stone that will kill the pair:</p> <pre><code>killerStone[{a_, b_, c_}] := If[Head[a] == Head[b] /. {black -&gt; 1, white -&gt; 0}, Head[c][2 a[] - b[], 2 a[] - b[]], Head[a][2 c[] - b[], 2 c[] - b[]]] </code></pre> <p>Finally, we only select those triples where killer stone's space is not already occupied:</p> <pre><code>sortStones[l_] := Sort[l, OrderedQ[{#1, #2} /. {black -&gt; List, white -&gt; List}] &amp;] triplesToKill[board_] := Module[ {triples = Select[sortStones /@ Subsets[board, {3}], isTriple]}, Select[triples, Block[ {ks = killerStone[#]}, FreeQ[board, _[ks[], ks[]]]] &amp;]] displayBoard[a, #] &amp; /@ triplesToKill[a] // Partition[#, 3, 3, {1, 1}, {}] &amp; // GraphicsGrid </code></pre> <p><img src="https://i.stack.imgur.com/QHj2c.png" alt="straightforward solution"></p> <h2>Graphics primitives</h2> <pre><code>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_} -&gt; black[x, y], Take[points, -n] /. {x_, y_} -&gt; 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[#[] &amp; /@ board], maxY = Max[#[] &amp; /@ board], n}, Graphics[{ grid[minX, minY, maxX, maxY], board /. { black[n__] -&gt; {Black, Disk[{n}, .4]}, white[n__] -&gt; {Thick, Circle[{n}, .4], White, Disk[{n}, .4]} }}, ImageSize -&gt; Small, Frame -&gt; True]]; displayBoard[board_, points_] := Show[ displayBoard[board], Graphics[ Map[{Red, Disk[{#[], #[]}, .2]} &amp;, points]]] </code></pre> https://mathematica.stackexchange.com/questions/46631/detecting-patterns-of-black-and-white-stones-on-a-2d-board/46640#46640 15 Answer by Mr.Wizard for Detecting patterns of black and white stones on a 2D board Mr.Wizard https://mathematica.stackexchange.com/users/121 2014-04-23T07:01:51Z 2017-02-21T17:42:53Z <p>One function comes to mind that already implements matching of multidimensonal rules: <a href="http://reference.wolfram.com/mathematica/ref/CellularAutomaton.html" rel="nofollow noreferrer"><code>CellularAutomaton</code></a>. Allow me to represent your board data like this:</p> <pre><code>board = SparseArray[ a /. h_[x_, y_] :&gt; ({-y - 1, x + 1} -&gt; h) /. {black -&gt; ●, white -&gt; ○}, {7, 7}, " "]; </code></pre> <p>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:</p> <pre><code>variants[x_, y_] := Union @@ Outer[ #@{y, x, y} ~Reverse~ #2 &amp;, {Identity, Transpose}, {{}, 1, 2, {1, 2}}, 1 ] expand[h_[x : {_, _, _}, v_]] := variants[x, {_, _, _}] :&gt; v // Thread </code></pre> <p>I now build the rules. The final rule merely keeps any element that is not at the center of a match unchanged.</p> <pre><code>rules = Join @@ expand /@ { {○, ○, ●} -&gt; "Q", {○, ●, ●} -&gt; "R", {_, z_, _} :&gt; z }; </code></pre> <p>Finally I apply them to my <code>board</code>. This shows the original, and after a single transformation:</p> <pre><code>MatrixForm /@ CellularAutomaton[rules, board, 1] </code></pre> <p><img src="https://i.stack.imgur.com/jaYwc.png" alt="enter image description here"></p> <p>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.</p> <p>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 <a href="http://reference.wolfram.com/mathematica/ref/ListCorrelate.html" rel="nofollow noreferrer"><code>ListCorrelate</code></a> 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.</p> https://mathematica.stackexchange.com/questions/46631/detecting-patterns-of-black-and-white-stones-on-a-2d-board/46642#46642 6 Answer by Victor K. for Detecting patterns of black and white stones on a 2D board Victor K. https://mathematica.stackexchange.com/users/1351 2014-04-23T07:22:44Z 2014-04-23T07:39:55Z <p>Here is my own <strong>rough</strong> 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.</p> <p>First, we'll store the board as a square matrix of symbols <code>B</code>, <code>W</code> and <code>"."</code>:</p> <pre><code>m = Partition[RandomChoice[{B, W, "."}, 25], 5] // MatrixForm </code></pre> <p>$\left( \begin{array}{ccccc} W &amp; . &amp; B &amp; B &amp; W \\ W &amp; . &amp; B &amp; . &amp; . \\ W &amp; B &amp; W &amp; B &amp; W \\ W &amp; B &amp; . &amp; W &amp; . \\ W &amp; . &amp; . &amp; . &amp; W \\ \end{array} \right)$</p> <p>Next, we'll generate a list of all possible <em>segments</em>, 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.</p> <pre><code>flatten1 := Flatten[#, 1] &amp; (* 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}]]] </code></pre> <p>For example,</p> <pre><code>segments[m[[1 ;; 3, 1 ;; 3]], 2] // Grid </code></pre> <p>returns</p> <p>$\left( \begin{array}{cc} \{W,W\} &amp; \{1,1,\text{vertical}\} \\ \{.,.\} &amp; \{1,2,\text{vertical}\} \\ \{B,B\} &amp; \{1,3,\text{vertical}\} \\ \{W,W\} &amp; \{2,1,\text{vertical}\} \\ \{.,B\} &amp; \{2,2,\text{vertical}\} \\ \{B,W\} &amp; \{2,3,\text{vertical}\} \\ \{W,.\} &amp; \{1,1,\text{horizontal}\} \\ \{.,B\} &amp; \{1,2,\text{horizontal}\} \\ \{W,.\} &amp; \{2,1,\text{horizontal}\} \\ \{.,B\} &amp; \{2,2,\text{horizontal}\} \\ \{W,B\} &amp; \{3,1,\text{horizontal}\} \\ \{B,W\} &amp; \{3,2,\text{horizontal}\} \\ \{W,.\} &amp; \{1,1,\text{diagSW}\} \\ \{.,B\} &amp; \{1,2,\text{diagSW}\} \\ \{W,B\} &amp; \{2,1,\text{diagSW}\} \\ \{.,W\} &amp; \{2,2,\text{diagSW}\} \\ \{W,.\} &amp; \{2,1,\text{diagNW}\} \\ \{.,B\} &amp; \{2,2,\text{diagNW}\} \\ \{W,.\} &amp; \{3,1,\text{diagNW}\} \\ \{B,B\} &amp; \{3,2,\text{diagNW}\} \\ \end{array} \right)$</p> <p>Finally, once we have all the segments, comparison to a pattern is easy - notice how in <code>matchPattern</code>, we generate all 4 patterns <code>{B,W,W,"."}</code>, <code>{W,B,B,"."}</code>, <code>{".",W,W,B}</code> and <code>{".",B,B,W}</code> from the pattern <code>{B,W,W,"."}</code> since our comparison is literal:</p> <pre><code>(* match a single pattern *) matchPattern1[p_] := Function[mat, Select[segments[mat, Length[p]], #[] == p &amp;]]; (* match multiple patterns *) matchPattern2[p_] := Function[mat, matchPattern1[#][mat] &amp; /@ p]; (* match all variations of a pattern *) matchPattern[p_] := Function[mat, flatten1[matchPattern2[{p, Reverse[p], p /. {W -&gt; B, B -&gt; W}, Reverse[p /. {W -&gt; B, B -&gt; W}]}][mat]]] </code></pre> <p>Now we can easily define a function to select all killable pairs:</p> <pre><code>killablePair = matchPattern[{B, W, W, "."}]; </code></pre> <p>and apply it to the above matrix</p> <pre><code>killablePair[m] </code></pre> <blockquote> <p>{{{".", B, B, W}, {1, 2, horizontal}}}</p> </blockquote> https://mathematica.stackexchange.com/questions/46631/detecting-patterns-of-black-and-white-stones-on-a-2d-board/46656#46656 4 Answer by Pellesatansfant for Detecting patterns of black and white stones on a 2D board Pellesatansfant https://mathematica.stackexchange.com/users/13904 2014-04-23T13:01:37Z 2014-04-23T17:34:35Z <p><strong>EDIT</strong></p> <p>Making this code runnable with Java reloader.</p> <ol> <li><p>Load the <a href="https://mathematica.stackexchange.com/questions/6144/looking-for-longest-common-substring-solution/6376#6376">Java reloader</a> (run the code from that post. For Mac OS X, see the comments below the post for a link to the Mac version)</p></li> <li><p>Compile the class:</p></li> </ol> <p>-</p> <pre><code>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&lt;board.length; row++ ) { String ch = \"\"; for( int col=0; col&lt;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 &amp;&amp; !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 &amp;&amp; !reachedEndColor ); if( reachedEndColor &amp;&amp; len &gt; 0 ) { System.out.println( \"Len = \" + len + \" from pos (\" + row + \" , \" + col + \"), dir (\" + dy + \" , \" + dx + \")\" ); } } private void solve( byte endColor ) { for( int row=1; row&lt;=8; row++ ) { for( int col=1; col&lt;=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 ); } }" </code></pre> <ol start="3"> <li><p>Run the code as </p> <pre><code>ShowJavaConsole[] JavaApplicationSIM`main[{}] </code></pre></li> </ol> <p>This program produces the following output (on the console):</p> <p>(first it shows the board)</p> <pre><code>++++++++++ + + + BBW + + WWBB + + B WBBB + + B B + + B B + + WBWWWW + + + ++++++++++ </code></pre> <p>Then the program tells all the positions that will qualify as a place to put the BLACK color.</p> <pre class="lang-none prettyprint-override"><code>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) </code></pre> <p>One can transfer the result back to Mathematica from Java with a bit more work. </p> https://mathematica.stackexchange.com/questions/46631/detecting-patterns-of-black-and-white-stones-on-a-2d-board/46670#46670 9 Answer by george2079 for Detecting patterns of black and white stones on a 2D board george2079 https://mathematica.stackexchange.com/users/2079 2014-04-23T19:31:12Z 2014-04-24T15:19:12Z <p>This may be a bit un-mathematicaesque, but it turns out to be convenient to store the board as a flat vector:</p> <p>(larger board for illustration)</p> <pre><code> n = 12; board0 = Flatten[ Table[0, {n^2}], 1]; v[icol_, jrow_] = icol + n (jrow - 1); </code></pre> <p>Now we can create lists of indices representing structures such as rows,columns, and diagonals. Here the function <code>diag</code> 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:</p> <pre><code> 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}]]; </code></pre> <p>manipulator illustrating how <code>diag</code> works</p> <pre><code> Manipulate[ board = board0; MapIndexed[ ((board[[#[]]] = Table[#[], {Length[#[]]}]) &amp;@ {diag[col, row, Sequence @@ #], First@#2}) &amp; , alldir ]; board[[v[col, row]]] = "X"; Partition[ board , n] // MatrixForm, {{col, 3}, 1, n, 1}, {{row, 3}, 1, n, 1}] </code></pre> <p><img src="https://i.stack.imgur.com/rHAeL.png" alt="enter image description here"></p> <p>now a random board, with 0-> empty, 1-> Red , -1->Black</p> <pre><code> 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}]}] &amp; /@ board1 , n]] </code></pre> <p><img src="https://i.stack.imgur.com/Yjahq.png" alt="enter image description here"></p> <p>now find all empty positions and search over all adjacent rows,columns,diagonals for the desired pattern:</p> <pre><code> 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 &amp; /@ open ]; GraphicsGrid[ Partition[ Graphics[{Switch[#, 1, Red, -1, Black, 0, White, 2, Green], Disk[{0, 0}], Black, Circle[{0, 0}]}] &amp; /@ MapIndexed[ If[Count[ (First@hits)[[;; , 1]] , First@#2] == 1, 2, #] &amp;, board1] , n]] </code></pre> <p><img src="https://i.stack.imgur.com/qBQWW.png" alt="enter image description here"></p> <p>just for fun a <a href="http://en.wikipedia.org/wiki/Reversi" rel="noreferrer">reversi</a> simulation (pattern is different from Pente)</p> <pre><code> 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}]}] &amp; /@ # , n]] &amp;; up = 1; down = -1; First@Last@Reap[ Sow[pb@board1 ]; While[0 &lt; 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 ]] &amp; /@ Flatten[Position[board1, 0]] , # != {} &amp;] ], board1[[choice = RandomChoice[(Length /@ hits) -&gt; hits]]] = 2 up; Sow[gg = pb@board1 ]; board1[[choice]] = up]] </code></pre> <p><img src="https://i.stack.imgur.com/q1fX4.gif" alt="enter image description here"></p>