Skip to main content
1 of 7
Rojo
  • 42.8k
  • 7
  • 98
  • 190

Performance tuning for game solving

There's a game I saw at a friend's yesterday, that I often see at people's homes, but never for enough time to think on it too hard. So I came home and I wanted to find a solution in Mathematica, so I did the following

First, some visual functions. The game consists of a board with some slots that can either have a piece on it (black dot in this visual representation) or be empty (white dot)

empty=Circle[{0,0},0.3];
filled=Disk[{0, 0}, 0.3];
    
plotBoard[tab_]:=Graphics[GeometricTransformation[#1,TranslationTransform/@
     Position[tab, #2]]&@@@{{empty, 0},{filled, 1}}, ImageSize->Small]

The starting board is the following.

tableroStart=({
 {-1, -1, 1, 1, 1, -1, -1},
 {-1, -1, 1, 1, 1, -1, -1},
 {1, 1, 1, 1, 1, 1, 1},
 {1, 1, 1, 0, 1, 1, 1},
 {1, 1, 1, 1, 1, 1, 1},
 {-1, -1, 1, 1, 1, -1, -1},
 {-1, -1, 1, 1, 1, -1, -1}
});

-1 is used to represent places where there can't be any pieces. 0 for empty slots. 1 for slots with a piece on it.

So,

plotBoard[tableroStart] // Framed

Mathematica graphics

Rules: Given a board such as the previous one, you can only move by "taking" a single piece, jumping over it. So, you take a piece, you choose one of the 4 straight directions, you jump over the adjacent piece and fall in an empty slot. In the starting board, there are 4 possible moves, all symmetrical.

In this code, moves are represented by rules, so, {3, 4}->{3, 6} represents a move of the piece in coordinates {3, 4}, to coordinates {3, 6}, jumping over the piece at {3, 5} and taking it out of the board.

So, let's start programming.

This finds the possible moves towards some specified zero position

findMovesZero[tab_,pos_List]:=pos+#&/@(Join[#, Reverse/@#]&[Thread@{{0, 1, 3, 4}, 2}])//
Extract[ArrayPad[tab, 2],#]&//
Pick[{pos-{2, 0}, pos+{2, 0}, pos-{0, 2}, pos+{0, 2}},UnitStep[Total/@Partition[
#, 2]-2], 1]->pos&//Thread[#, List, 1]&

Lists all the possible moves given a board tab

i:findMoves[tab_]:=i=Flatten[#, 1]&[findMovesZero[tab, #]&/@Position[tab, 0]]

Given the board tab, makes the move

makeMove[tab_, posFrom_->posTo_]:=ReplacePart[tab , {posFrom->0, Mean[{posFrom, posTo}]->0,posTo->1}];

Now, the solving function

(* solve, given a board tab, returns a list of subsequent moves to win, or $Failed *)
(* markTab is recursive. If a board is a success, marks it with $Success and makes all subsequent markTab calls return $NotNecessary *)
(* If a board is not a success and doesn't have any more moves, returns $Failed. If it has moves, it just calls itself on every board,
saving the move made in the head of the new boards. I know, weird *)
Module[{$Success,$NotNecessary, parseSol, $guard, markTab},

markTab[tab_/;Count[tab, 1, {2}]===1]:=$Success/;!($guard=False)/;$guard;
i:markTab[tab_]:=With[{moves=findMoves[tab]},(i=If[moves==={}, $Failed,(#[markTab@makeMove[tab, #]]&/@moves)])/;$guard];
markTab[tab_]/;!$guard:=$NotNecessary;

(* parseSol converts the tree returned by markTab into the list of moves until $Success, or in $Failed *)
parseSol[sol_]/;FreeQ[{sol}, $Success]:=$Failed;
parseSol[sol_]:=sol[[Apply[Sequence,#;;#&/@First@Position[sol, $Success]]]]//#/.r_Rule:>Null/;(Sow[r];False)&//Reap//#[[2, 1]]&;

solve[tab_]:=Block[{$guard=True},parseSol@markTab@tab];
]

Solution visualization function

plotSolution[tablero_, moves_]:=
MapIndexed[Show[plotBoard[#1], Epilog->{Red,Dashed,Arrow[List@@First@moves[[#2]]]}]&, Rest@FoldList[makeMove[#, #2]&,tablero,moves]]//
Prepend[#, plotBoard[tablero]]&//Grid[Partition[#, 4, 4, 1, Null], Frame->All]&

(* Solves and plots *)
solveNplot = With[{sol=solve[#]},If[sol===$Failed, $Failed, plotSolution[#, sol]]]&;

In action:

solveNplot[( {
   {-1, -1, 1, 1, 0, -1, -1},
   {-1, -1, 1, 1, 0, -1, -1},
   {1, 1, 0, 0, 0, 0, 0},
   {1, 1, 0, 0, 0, 0, 0},
   {1, 1, 0, 0, 0, 0, 0},
   {-1, -1, 1, 1, 1, -1, -1},
   {-1, -1, 1, 1, 1, -1, -1}
  } )]

returns, after about a min's though,

Mathematica graphics

So, the question is. How can we make it efficient enough so it can do the trick for an almost filled board like tableroStart?

The first move is actually always the same let alone symmetries so we could start a move ahead

Rojo
  • 42.8k
  • 7
  • 98
  • 190