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