The Game of Hex in Mathematica
The flow in my program is:
- I have one global variable,
board
, which is an 11x11 matrix. Each matrix element corresponds to a hexagon on the board. - I pass the board to
renderBoard
which passes each matrix element along with that element's position torenderHexagonEdge
. i.e. step 3-7 is done once for each hexagon. renderHexagonEdge
takes the given position and draw the outline of a hexagon at that position. It also passes the the state and position on toeventHandler
.eventHandler
specifies that when the encapsulated graphics expression is clicked on,boardClicked
should be called.boarClicked
is a function that updates the globalboard
matrix, by acting on the click and letting the computer choose one hexagon.eventHandler
passes its information on tomouseAppearance
.mouseAppearance
specifies that the cursor should be a link hand when it hovers a hexagon.mouseAppearance
passes its information on tomouseover
.mouseover
specifies that when the cursor hover a hexagon, that hexagon should turn blue.mouseover
passes its information on torenderHexagon
.renderHexagon
draws the hexagon in the specified color.
That I can explain my program this easily is indicative of good design. The main goal of any code design is to avoid complexity, and complexity is usually hard to describe. The guiding principle that got me here was to consciously try to model the entire thing as a chain of stateless functions, because I know that when I do this the end result will be very easy to work with. If I want to add a new feature I can just make a new function and put it into the chain of functions described above. If I want to remove, say, mouseAppearance
which changes the cursor to a link hand, I can do this by linking eventHandler
directly mouseover
. So it's very easy to add or remove new features without having to change almost anything else in the program or even look at the rest of the code.
A small note: The reason why I plot the edges of the hexagons and hexagons separately is because I don't want the edges to be clickable. Since the edges overlap, it will be possible to select two hexagons at once if they are clickable.
hexagon[{i_, j_}] := Polygon@CirclePoints[
{-Sqrt[3] i + 0.5 Sqrt[3] j, -1.5 j},
{1, 90 Degree}, 6
]
renderHexagon[{i_, j_}, color_?ColorQ, edge_: None] := {
color, EdgeForm[edge], hexagon[{i, j}]
}
renderHexagon[0, {i_, j_}] := renderHexagon[{i, j}, LightGray]
renderHexagon[1, {i_, j_}] := renderHexagon[{i, j}, Blue]
renderHexagon[2, {i_, j_}] := renderHexagon[{i, j}, Red]
renderHexagonEdge[state_, {i_, j_}] := {
eventHandler[state, {i, j}],
renderHexagon[{i, j}, Transparent, Black]
}
mouseover[state_, {i_, j_}] := Mouseover[
renderHexagon[state, {i, j}],
renderHexagon[1, {i, j}]
]
mouseAppearance[state_, {i_, j_}] := MouseAppearance[
mouseover[state, {i, j}], "LinkHand"
]
eventHandler[state_, {i_, j_}] := EventHandler[mouseAppearance[state, {i, j}], {
"MouseClicked" :> boardClicked[{i, j}]
}]
boardClicked[{i_, j_}] := If[
board[[i, j]] == 0,
board[[i, j]] = 1; computer[]
]
computer[] := With[{ind = RandomChoice@Position[board, 0]},
board[[First[ind], Last[ind]]] = 2
]
renderBoard[board_] := Deploy@Graphics[
MapIndexed[renderHexagonEdge, board, {2}],
ImageSize -> 500
]
To play:
board = ConstantArray[0, {11, 11}];
Dynamic[renderBoard[board], TrackedSymbols :> {board}]
Check Winning Condition
To stop the game when either player has won, one might change the definitions to include Anton Antonov's hexCompletePathQ
from his answer below.
boardClicked[{i_, j_}] := If[
board[[i, j]] == 0 && player == 1,
board[[i, j]] = 1; player = 2;
computer[]
]
computer[] := With[{ind = RandomChoice@Position[board, 0]},
board[[First[ind], Last[ind]]] = 2;
If[
HexCompletePathQ[11, 11, Position[Reverse@board, 1], "X"] ||
HexCompletePathQ[11, 11, Position[Reverse@board, 2], "Y"],
player = 0,
player = 1
]]
player = 1;
board = ConstantArray[0, {11, 11}];
Dynamic[renderBoard[board], TrackedSymbols :> {board}]
Online Multiplayer Version
For those that want to play over the Internet against another person, I posted such a version here.
Here is an answer that provides modular definitions that allow
plotting the play-table and players moves with different options, and
testing for a complete path by a player.
(The function definitions are given in the last section.)
Plotting
This plots the the Hex 8x8 grid and the paths of the X player and Y player:
HexGrid[8, 8, {{1, "a"}, {1, "b"}, {2, "b"}, {3, "b"}, {3, "c"}}, {{5,
8}, {6, 7}, {6, 6}}]
The full signature is:
HexGrid[
nx_Integer, ny_Integer,
xPlayerPath : {{_Integer, _Integer | _String} ...},
yPlayerPath : {{_Integer, _Integer | _String} ...},
opts : OptionsPattern[] ]
Another example same grid and player moves as above, but with different coloring:
HexGrid[8, 8, {{1, 1}, {1, 2}, {2, 2}, {3, 2}, {3, 3}}, {{5, 8}, {6,
7}, {6, 6}}, "CellColor" -> Lighter[Pink],
"XPlayerColor" -> Yellow, "YPlayerColor" -> Green]
Complete path check
The complete path check can be done in several ways. Since OP wants to be able to develop the game with strategies etc. I think graph based definitions would be very useful for the development process.
Using the graph representation of the play-table (see below) the plot function HexGrid
can recognize and mark with a line complete paths.
Find paths:
hgr = HexGraph[8, 8];
xpath = RandomChoice@FindPath[hgr, {1, 2}, {8, 3}, 12, 900];
ypath = Complement[RandomChoice@FindPath[hgr, {2, 1}, {7, 8}, 13, 60], xpath];
Plot Hex play-table and paths:
HexGrid[8, 8, xpath, ypath, "CompletePathColor" -> Cyan, "CompletePathThickness" -> 0.013]
More details for the graph representation
This function call makes the Hex game graph:
hgr = HexGraph[8, 8]
Now let us find a path from side to side for X player, visualize it, verify it recognized as a complete path.
cpath = FindShortestPath[hgr, {1, 2}, {8, 3}];
HighlightGraph[hgr, Subgraph[hgr, cpath]]
HexCompletePathQ[hgr, cpath, "X"]
HexCompletePathQ[8, 8, cpath, "X"]
If we remove some nodes from the path the test is not passed:
HexCompletePathQ[hgr, Most[cpath], "X"]
HexCompletePathQ[hgr, Drop[cpath, {4}], "X"]
(* Out[179]= False
Out[180]= False *)
Another example for Y player:
Definitions
Plotting functions
hexagonPoints = Table[{Cos[i \[Pi]/3], Sin[i \[Pi]/3]}, {i, 0, 5}];
hexagonPoints = RotateLeft[hexagonPoints.RotationMatrix[-\[Pi]/6]];
Clear[HexagonTranslationVector]
HexagonTranslationVector[hexagonPoints_, pInd1_, pInd2_] :=
Block[{v},
v = Mean[{hexagonPoints[[pInd1]], hexagonPoints[[pInd2]]}] -
Mean[hexagonPoints];
2 v
];
Clear[SpreadHexagons]
SpreadHexagons[hexagonPoints_, nx_Integer, ny_Integer] :=
Block[{tv1, tv2, s, h},
{tv1, tv2} = {HexagonTranslationVector[hexagonPoints, 4, 5],
HexagonTranslationVector[hexagonPoints, 5, 6]};
Table[Map[# + (i*tv1 + j*tv2) &, hexagonPoints], {i, 0,
nx - 1}, {j, 0, ny - 1}]
];
Clear[HexGrid]
Options[HexGrid] = {"GridColor" -> Purple,
"CellColor" -> GrayLevel[0.9], "Borders" -> True,
"XPlayerColor" -> Red, "YPlayerColor" -> Blue,
"CompletePathColor" -> White, "CompletePathThickness" -> 0.02};
HexGrid[
nx_Integer, ny_Integer,
xPlayerPath : {{_Integer, _Integer | _String} ...},
yPlayerPath : {{_Integer, _Integer | _String} ...},
opts : OptionsPattern[]] :=
Block[{gridColor, cellColor, bordersQ, xBorderIDs, yBorderIDs,
fullGrid, grid, xPlayerColor, yPlayerColor, cPathColor,
cPathThickness, yRules},
gridColor = OptionValue["GridColor"];
cellColor = OptionValue["CellColor"];
bordersQ = TrueQ[OptionValue["Borders"]];
xPlayerColor = OptionValue["XPlayerColor"];
yPlayerColor = OptionValue["YPlayerColor"];
cPathColor = OptionValue["CompletePathColor"];
cPathThickness = OptionValue["CompletePathThickness"];
xBorderIDs = Range[1, nx];
yBorderIDs = Take[CharacterRange["a", "z"], ny];
fullGrid = SpreadHexagons[hexagonPoints, nx + 2, ny + 2];
grid = fullGrid[[2 ;; nx + 1, 2 ;; ny + 1]];
yRules = Thread[# -> Range[Length[#]]] &@CharacterRange["a", "z"];
Graphics[{
FaceForm[cellColor], EdgeForm[gridColor],
Polygon /@ grid,
If[! bordersQ, Null,
{MapThread[
Text, {yBorderIDs,
Take[Mean /@ fullGrid[[1]], {2, nx + 1}]}],
MapThread[
Text, {yBorderIDs,
Take[Mean /@ fullGrid[[-1]], {2, nx + 1}]}],
MapThread[
Text, {xBorderIDs,
Take[Mean /@ Transpose[fullGrid][[1]], {2, nx + 1}]}],
MapThread[
Text, {xBorderIDs,
Take[Mean /@ Transpose[fullGrid][[-1]], {2, nx + 1}]}]}
],
If[Length[xPlayerPath] == 0,
Null, {FaceForm[xPlayerColor],
Polygon[grid[[Sequence @@ #]]] & /@ (xPlayerPath /. yRules)}],
If[Length[yPlayerPath] == 0,
Null, {FaceForm[yPlayerColor],
Polygon[grid[[Sequence @@ #]]] & /@ (yPlayerPath /. yRules)}],
If[! HexCompletePathQ[nx, ny, xPlayerPath /. yRules, "X"],
Null, {Thickness[cPathThickness], cPathColor,
Line[Mean[grid[[Sequence @@ #]]] & /@ (xPlayerPath /.
yRules)]}],
If[! HexCompletePathQ[nx, ny, yPlayerPath /. yRules, "Y"],
Null, {Thickness[cPathThickness], cPathColor,
Line[Mean[grid[[Sequence @@ #]]] & /@ (yPlayerPath /. yRules)]}]
}, AspectRatio -> Automatic]
];
Complete/winning path check
The variable hexagonPoints
is redefined below in order the code of this sub-section to be independent.
hexagonPoints = Table[{Cos[i \[Pi]/3], Sin[i \[Pi]/3]}, {i, 0, 5}];
hexagonPoints = RotateLeft[hexagonPoints.RotationMatrix[-\[Pi]/6]];
Clear[HexGraph]
HexGraph[nx_Integer, ny_Integer] :=
Block[{nodes},
nodes =
Flatten[Map[Mean, SpreadHexagons[hexagonPoints, nx, ny], {2}],
1];
VertexReplace[
NearestNeighborGraph[
nodes, {All, Norm[nodes[[1]] - nodes[[2]]] 1.01}],
MapThread[
Rule, {nodes, Flatten[Table[{i, j}, {i, nx}, {j, ny}], 1]}]]
];
Clear[HexCompletePathQ]
HexCompletePathQ[nx_Integer, ny_Integer,
path_: {{_Integer, _Integer} ...}, playerID : ("X" | "Y")] :=
HexCompletePathQ[HexGraph[nx, ny], path, playerID];
HexCompletePathQ[hgr_, path_: {{_Integer, _Integer} ...},
playerID : ("X" | "Y")] :=
Block[{sgr, cs, hvs},
If[Length[path] == 0, Return[False]];
sgr = Subgraph[hgr, path];
cs = ConnectedComponents[sgr];
sgr = Subgraph[hgr,
cs[[Position[Length /@ cs, Max[Length /@ cs]][[1, 1]]]]];
hvs = VertexList[hgr];
If[playerID == "X",
Length[Intersection[VertexList[sgr], Cases[hvs, {1, _}]]] > 0 &&
Length[
Intersection[VertexList[sgr],
Cases[hvs, {Max[hvs[[All, 1]]], _}]]] > 0,
(* playerID == "Y"*)
Length[Intersection[VertexList[sgr], Cases[hvs, {_, 1}]]] > 0 &&
Length[
Intersection[VertexList[sgr],
Cases[hvs, {_, Max[hvs[[All, 2]]]}]]] > 0
]
];
Mostly working, just don't click the intersections. I seemed to have reversed the colours, but that's easily fixed, just set re
and be
to be the opposite ones.
Human v Human sofar
Updated to prevent repeat moves
Primer:
p[x_, y_] :=
Rotate[Polygon[CirclePoints[{x, y}, 1/Cos[(7 π)/6], 6]], Pi/2]
list = {{{{0}}}};
list2 = {{{{0}}}};
board = Table[
p[i + 2 j, i 2 Cos[(7 π)/6]], {i, 0, 11}, {j, 0, 11}];
re = {Table[p[i - 2, i 2 Cos[(7 π)/6]], {i, 0, 11}],
Table[p[i + 24, i 2 Cos[(7 π)/6]], {i, 0, 11}]};
be = {Table[p[2 j - 1, - 2 Cos[(7 π)/6]], {j, 0, 12}],
Table[p[2 j + 10, 24 Cos[(7 π)/6]], {j, 0, 12}]};
And here the actual game:
DynamicModule[{pt = {-10, -10}, rb = 1},
ClickPane[
Dynamic@Graphics[{FaceForm[Lighter[Gray]], EdgeForm[Black], board,
FaceForm[Lighter[Red]], re, FaceForm[Red],
If[rb == 1 &&
Position[list[[All, 1, 1]],
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]][[1,
1]]] == {} &&
Position[list2[[All, 1, 1]],
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]][[1,
1]]] == {}, rb = 2;
Rest[
AppendTo[list2,
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]]]],
Rest[list]], FaceForm[Lighter[Blue]], be, FaceForm[Blue],
If[rb == 2 &&
Position[list[[All, 1, 1]],
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]][[1,
1]]] == {} &&
Position[list2[[All, 1, 1]],
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]][[1,
1]]] == {}, rb = 1;
Rest[
AppendTo[list,
p[Round[pt[[1]]], Round[pt[[2]], 2 Cos[(7 π)/6]]]]],
Rest[list2]]}, ImageSize -> Large,
PlotRange -> {{-3, 36}, {4, -32}}], (pt = #) &]]
Note that you need to disable Dynamic Updating, and then enable it again to start a new game.