The Game of Hex in Mathematica

Question

The Game of Hex is a game originally developed by Nash, and it's rules are very simple. You start out with a hexagonal tiling of some size:

There are two players. The game is in turns, and every time it is your turn you fill a hexagon anywhere on the board with your color. The object of the game is to form a connecting path from one of your colored sides to the other.

Here is some more info and here is an online version. I want to make this game in Mathematica, with a computer that just does random moves (I'll add in my own strategies and things later) However, I have absolutely zero experience with games, and so far all my attempts have been futile. I've been able to make a hexagonal tiling and the ability to click it but never got past that (I'll provide that code if you want). I don't need fancy graphics, but just a robust, working program. Can anyone help me out with this?

More specifically,

• how do I make a hexagonal tiling that I can click and
• detect when I have made a connected line?

Answer 1

The flow in my program is:

1. I have one global variable, board, which is an 11x11 matrix. Each matrix element corresponds to a hexagon on the board.
2. I pass the board to renderBoard which passes each matrix element along with that element's position to renderHexagonEdge. i.e. step 3-7 is done once for each hexagon.
3. renderHexagonEdge takes the given position and draw the outline of a hexagon at that position. It also passes the the state and position on to eventHandler.
4. eventHandler specifies that when the encapsulated graphics expression is clicked on, boardClicked should be called. boarClicked is a function that updates the global board matrix, by acting on the click and letting the computer choose one hexagon. eventHandler passes its information on to mouseAppearance.
5. mouseAppearance specifies that the cursor should be a link hand when it hovers a hexagon. mouseAppearance passes its information on to mouseover.
6. mouseover specifies that when the cursor hover a hexagon, that hexagon should turn blue. mouseover passes its information on to renderHexagon.
7. 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.

Answer 2

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
    ]
   ];

Answer 3

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.

Answer 4

Dead end

When I first saw this question I immediately thought of a Voronoi diagram because it is so easy to do this:

xy = Join @@ Array[{2 #2 - #, Sqrt[3] #} &, {14, 14}];

VoronoiMesh[xy]

Or perhaps more promisingly with ListDensityPlot:

ListDensityPlot[
  {##, RandomInteger[2]} & @@@ xy
  , InterpolationOrder -> 0
  , Mesh -> All
][[{1}]]

I really wanted this to work however I failed to build anything clean on top of this that did not amount to using one of these as a clever/obfuscated way generate Polygons rather than as a foundation for the interface itself. It is interesting to be able to use Nearest in a ClickPane to align with the hex grid but using that information to update the data to be plotted by ListDensityPlot proves inelegant, as does trimming the edges of the board.

I therefore abandoned this approach and sought any possible improvement to C. E.'s clean answer.

C. E.'s method

Here therefore is my refactoring of C. E.'s method. My changes include:

• Use pattern aliases to reduce redundancy and enforce consistency in function specifications

• Eliminate a couple of functions that I found too granular

• Merge hexagon and renderHexagon

• shorten CirclePoints usage

• shorten computer[]

Code:

(*pattern aliases*)
p1 = p1 : {i_, j_};
spec = spec : PatternSequence[state_, p1];

(*parameters*)
crules = {0 -> LightGray, 1 -> Blue, 2 -> Red};

(*internal functions*)
hexagon[p1] := Polygon @ CirclePoints[{Sqrt[3] (j - 2 i), -3 j}, {2, 90°}, 6]

hexagon[p1, color_?ColorQ, edge_: None] := {color, EdgeForm[edge], hexagon[p1]}

hexagon[spec] := hexagon[p1, state /. crules]

boardClicked[p1] /; board[[i, j]] == 0 := (board[[i, j]] = 1; computer[];)

computer[] := (board[[##]] = 2) & @@ RandomChoice @ Position[board, 0]

eventHandler[spec] := 
  hexagon[spec] ~
    Mouseover~ hexagon[1, p1] ~
    MouseAppearance~ "LinkHand" ~
    EventHandler~ {"MouseClicked" :> boardClicked[p1]}

gameTile[spec] := {eventHandler[spec], hexagon[p1, Transparent, Black]}

renderBoard[board_, size_ : 500] := 
  Graphics[MapIndexed[gameTile, board, {2}], ImageSize -> size] // Deploy

(*gameplay*)
board = ConstantArray[0, {11, 11}];
Dynamic[renderBoard[board], TrackedSymbols :> {board}]