The Game of Hex in Mathematica

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.

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.