Creating hexagonal grid (hexagonal grid graph)

Question

Is there a function that can create hexagonal grid?

We have square grid graph, where we can specify m*n dimensions:

GridGraph[{m, n}]

We have triangular grid graph (which works only for argument n up to 10 - for unknown reason):

GraphData[{"TriangularGrid", n}, "Graph"]

I can not find a function that would generate a hexagonal grid graph. I would like it like it is with GridGraph something like HexagonalGridGraph[{m,n,o}] where m,n,o are dimensions m*n*o of planar graph - or other way said - "lengths" of the sides of the graph.

I can make my own code, I am asking just in case there already exist implemented function.

UPDATE:

What I mean by m*n*o hexagonal grid is for example this 3*5*7 hexagonal grid:

My code for producing it is very long and cumbersome so I will not upload it unless I can make it simpler.

Answer 1

With IGraph/M:

IGMeshGraph@IGLatticeMesh["Hexagonal", {6, 4}]

We can also crop it to a hexagon:

IGMeshGraph@IGLatticeMesh["Hexagonal", Polygon@CirclePoints[10, 6]]

It can also generate many other kinds of lattices, not just hexagonal.

Answer 2

Here is my generalization of the code from link provided by @LouisB:

HexagonalGridGraph2[{wide1_Integer?Positive, wide2_Integer?Positive, 
   wide3_Integer?Positive}, opts : OptionsPattern[Graph]] := 
 Module[{cells, edges, vertices}, 
  cells = 
   Flatten[Table[
     CirclePoints[{Sqrt[3] (1 j + k - 2 ) + Sqrt[3] (1 j + l - 2 ), 
       3 k - 2 - 3 l}, {2, \[Pi]/2}, 6], {j, wide1}, {k, wide2}, {l, 
      wide3}], 2];
  edges = Union[Sort /@ Flatten[Partition[#, 2, 1, 1] & /@ cells, 1]];
  vertices = Union[Flatten[edges, 1]];
  IndexGraph[
   Graph[UndirectedEdge @@@ edges, opts, 
    VertexCoordinates -> Thread[vertices -> vertices]]]]

And here are some examples:

Sort /@ Tuples[Range[4], {3}] // Union;
Partition[
  Rasterize /@ (HexagonalGridGraph2[#, PlotLabel -> #, 
       ImageSize -> {100, 100}] & /@ %), 5];
ImageAssemble[%]

Answer 3

We can generate the vertex coordinates using a slightly modified version of azerbajdan's cells and use them with NearestNeighborGraph:

ClearAll[vCoords]
vCoords = DeleteDuplicates @ Flatten[
   Table[CirclePoints[{(2 j + k + l - 4) Sqrt[3] , 3 k - 2 - 3 l}, {2, π/2}, 6], 
     {j, #}, {k, #2}, {l, #3}], 3] &;

ClearAll[hexGridGraph]
hexGridGraph = Module[{v = vCoords @@ #},
   NearestNeighborGraph[v, ##2, VertexCoordinates -> v]] &;

Examples:

hexGridGraph[{3, 5, 7}, 
  VertexLabels -> Placed["Index", Center], 
  VertexSize -> .7, 
  VertexStyle -> White, 
  VertexLabelStyle -> 8, 
  ImageSize -> 400]

args = Sort /@ Tuples[Range[4], {3}] // Union;

hexGridGraph[#, PlotLabel -> #, ImageSize -> {100, 100}] & /@ args // 
    Multicolumn[#, 5] &

Answer 4

Edit-7

θ = π/2;
vertexs = CirclePoints[{Sqrt[3]/3, π/2 + θ}, 3];
coordinate[{λ1_, λ2_, λ3_}] := 
  1/(λ1 + λ2 + λ3) {λ1, λ2, λ3} . vertexs;
{a, b, c} = {6, 2, 5};
δ = 3;
n = Total[{a, b, c}] + δ;
coords = {{b, n - b, 0}, {0, n - b, b}, {0, c, n - c}, {c, 0, 
    n - c}, {n - a, 0, a}, {n - a, a, 0}};
pts = coordinate /@ 
   Select[Tuples[{Range[0, n - a], Range[0, n - b], Range[0, n - c]}],
     Total@# == n &];
polys = CirclePoints[#, {1/(Sqrt[3] n), π/2 + θ}, 6] & /@ 
   pts;
graph = MeshConnectivityGraph[
   Line /@ Partition[#, 2, 1, 1] & /@ polys // Graphics // 
    DiscretizeGraphics, PlotTheme -> "LargeGraph"];
g = Graphics[{Cyan, Polygon[coordinate /@ coords], Red, Point@pts}];
GraphicsRow[{g, graph}]

Edit-6

To truncated the equilateral triangle,we use the idea of TernaryListPlot.

Clear["Global`*"];
{p, q, r} = {4, 7, 8};
L = 9;
n = p + q + r + L;
unit = 1/n;
{a, b, c} = {p - 2, q - 2, r - 2}*unit;
data = Complement[
   Flatten[Table[{u, 1 - u - w, w}, {u, 0, 1, unit}, {w, 0, 1 - u, 
      unit}], 1], 
   Flatten[{Table[{u, 1 - u - w, w}, {u, 0, a, unit}, {w, 1 - a, 1, 
       unit}], Table[{u, v, 1 - u - v}, {u, 1 - b, 1, unit}, {v, 0, b,
        unit}], 
     Table[{1 - v - w, v, w}, {v, 1 - c, 1, unit}, {w, 0, c, unit}]}, 
    2]];
ternarylistplot = 
  TernaryListPlot[data, 
   Prolog -> {Polygon[{{a, 0, 1 - a}, {1 - b, 0, b}, {1 - b, b, 
        0}, {c, 1 - c, 0}, {0, 1 - c, c}, {0, a, 1 - a}}], Blue, 
     Polygon[{{a, 0, 1 - a}, {1 - b, 0, b}, {1 - b, b, 0}, {a, b, 
        1 - a - b}}], Green, 
     Polygon[{{1 - b, b, 0}, {c, 1 - c, 0}, {0, 1 - c, c}, {1 - b - c,
         b, c}}], Yellow, 
     Polygon[{{0, 1 - c, c}, {0, a, 1 - a}, {a, 0, 1 - a}, {a, 
        1 - a - c, c}}], Red, 
     Polygon[{{1, 0, 0}, {1 - b, b, 0}, {1 - b, 0, b}}], 
     Polygon[{{0, 1, 0}, {0, 1 - c, c}, {c, 1 - c, 0}}], 
     Polygon[{{0, 0, 1}, {a, 0, 1 - a}, {0, a, 1 - a}}]}];
ternary[{p1_, p2_, p3_}] := {p1 + 1/2 p2, Sqrt[3]/2 p2};
pts = ternary /@ data;
polys = CirclePoints[#, {1/(Sqrt[3] n), π/2}, 6] & /@ pts;
graph = MeshConnectivityGraph[
   Line /@ Partition[#, 2, 1, 1] & /@ polys // Graphics // 
    DiscretizeGraphics, PlotTheme -> "LargeGraph"];
Labeled[GraphicsRow[{ternarylistplot, graph}], {n - p - q, q, 
  n - q - r, r, n - r - p, p}]

Edit-5

Try to directly to construct the type {L + c, b, L + a, c, L+ b, a} where a,b,c are positive integers and L is a non-negative integer(when L==0 then the type become {c,b,a,c,b,a} is the original type {c,b,a}.

Clear["Global`*"];
e = {e1, e2, e3, e4, e5, e6} = CirclePoints[{1, 0}, 6];
L = 9;
{a, b, c} = {4, 7, 8};
triangle = 
  Flatten[Table[{i, k - i} . {e1, e2}, {k, 0, L}, {i, 0, k}], 1];
parallelogram1 = 
  Flatten[Table[{L, 0} . {e1, e2} + {i, j} . {e1, e3}, {i, 1, c}, {j, 
     0, L + a}], 1];
parallelogram2 = 
  Flatten[Table[{0, L} . {e1, e2} + {i, j} . {e3, e5}, {i, 1, a}, {j, 
     0, L + b}], 1];
parallelogram3 = 
  Flatten[Table[{0, 0} . {e1, e2} + {i, j} . {e5, e1}, {i, 1, b}, {j, 
     0, L + c}], 1];
graphics = 
  Graphics[{Red, Point /@ triangle, Blue, Point /@ parallelogram1, 
    Green, Point /@ parallelogram2, Brown, Point /@ parallelogram3}];
pts = Join[triangle, parallelogram1, parallelogram2, parallelogram3];
vor = VoronoiMesh[pts];
graph = MeshPrimitives[VoronoiMesh[pts], {2, "Interior"}] // 
     Graphics // DiscretizeGraphics // MeshConnectivityGraph;
Labeled[GraphicsRow[{graphics, graph}], {L + c, b, L + a, c, L + b, 
  a}]

Edit-4

Besides of type {m,n,o},here we want to find the type {n[1],n[2],n[3],n[4],n[5],n[6]}. Simple calculate, for example

Solve[Array[n, 6] . CirclePoints[{0, 0}, {1, 0}, 6] == 0, 
 Array[n, 6], PositiveIntegers]

We can find that it satisfy two equations.

{n[1] - n[4] + n[2] - n[5] == 0, n[2] - n[5] + n[3] - n[6] == 0}

( so {m,n,o,m,n,o} always satisfy this relation)

e[1] = AngleVector[0];
e[3] = AngleVector[2 π/3];
e[2] = e[1] + e[3];
e[4] = -e[1];
e[5] = -e[2];
e[6] = -e[3];
sol = Simplify[
   SolveValues[Array[n, 6] . Array[e, 6] == {0, 0}, Array[n, 6], 
     PositiveIntegers][[1]], Array[C, 5] ∈ PositiveIntegers];
type = sol /. Thread[Array[C, 5] -> RandomInteger[{1, 10}, 5]]
bd = Accumulate@
   Catenate[MapThread[ConstantArray, {Array[e, 6], type - 1}]];
reg = BoundaryMeshRegion[bd, 
   Line /@ {##, #1} & @@ Partition[Range@Length@bd, 2, 1, 1]];
allpts = Tuples[Range[0, 2 Max@type], 2] . {e[1], e[3]};
pts = Pick[allpts, RegionMember[reg]@allpts];
Graphics[{EdgeForm[Blue], FaceForm[], 
  RegularPolygon[#, {1/Sqrt[3], π/2}, 6] & /@ pts, Red, Point@bd}]

{12, 10, 11, 15, 7, 14}

Edit-3

{m, n, o} = {3, 5, 7};
 Graphics[{EdgeForm[Blue], FaceForm[], 
  RegularPolygon[#, {1, 0}, 
     6] & /@ (Sqrt[
      3] SolveValues[{0 <= x <= o - 1, 0 <= y <= n - 1, 
        0 <= z <= m - 1, x == 0 || y == 0 || z == 0}, {x, y, z}, 
       Integers] . CirclePoints[{1, Pi/6}, 3])}]

{x, y, z} = {7, 5, 3};
bases = CirclePoints[{1, 30 Degree}, 3];
coordinates = 
  Catenate[{Tuples[{Range[0, x - 1], Range[0, y - 1], {0}}], 
    Tuples[{Range[1, x - 1], {0}, Range[1, z - 1]}], 
    Tuples[{{0}, Range[0, y - 1], Range[1, z - 1]}]}];
Graphics[{EdgeForm[Blue], FaceForm[], 
  RegularPolygon[#, {1, 0}, 6] & /@ (Sqrt[3]*coordinates . bases)}]

Edit-2

The ideal comes from 3D.

Graphics3D[Cuboid[], BoxRatios -> {5, 7, 3}, Boxed -> False, 
 ViewProjection -> "Orthographic", ViewPoint -> {2.0, -1.7, 2.0}]

{eX, eY, eZ} = CirclePoints[{1, 30 Degree}, 3];
{x, y, z} = {7, 5, 3};
(*{x,y,z}={8,8,8};*)
pXY = Sqrt[3] Tuples[{Range[x] - 1, Range[y - 1]}] . {eX, eY};
pYZ = Sqrt[3] Tuples[{Range[y] - 1, Range[z - 1]}] . {eY, eZ};
pZX = Sqrt[3] Tuples[{Range[z] - 1, Range[x - 1]}] . {eZ, eX};
Graphics[{EdgeForm[White], Red, RegularPolygon[#, {1, 0}, 6] & /@ pXY,
   Green, RegularPolygon[#, {1, 0}, 6] & /@ pYZ, Blue, 
  RegularPolygon[#, {1, 0}, 6] & /@ pZX, Black, Point[pXY], 
  PointSize[Medium], Point[pYZ], PointSize[Large], Point[pZX]}]

Edit-1

If we introduce three coordinates {x1,y1,z1} and three bases e1,e2,e3 instead of just two coordinates and two bases, the construction of the type {m, n, o} = {3, 5, 7} is relatively easy.

{m, n, o} = {3, 5, 7};
eM = AngleVector[90 Degree];
eN = AngleVector[150 Degree];
eO = AngleVector[30 Degree];
pts = Sqrt[3] Tuples[Range /@ {m, n, o}] . {eM, eN, eO} // Union;
Graphics[{EdgeForm[White], 
  Table[RegularPolygon[p, {1, 0}, 6], {p, pts}], Red, Point[pts]}]

Graphics[{EdgeForm[Blue], FaceForm[], 
  Table[RegularPolygon[p, {1, 0}, 6], {p, pts}], Red, Point[pts], 
  Riffle[{Red, Green, Blue}, Arrow[{{0, 0}, 2 #}] & /@ {eM, eN, eO}]}]

Answer 5

You can make a hexagonal grid using only MMA built in functions. You may adapt the code to your liking:

c3 = Cos[30 Degree]; s3 = Sin[30 Degree];
del1 = {Sqrt[c3^2 + Sqrt[(1 + s3^2)^2 + c3^3]], c3} // N;
del2 = {-Sqrt[c3^2 + Sqrt[(1 + s3^2)^2 + c3^3]], c3} // N;
del3 = {0, 2 c3};
trans[del_] := Map[(del + #) &, hex, {2}];
n = 3;
grid = Flatten[
   Table[trans[i1 del1 + i2 del2 + i3 del3], {i1, n}, {i2, n}, {i3, 
     n}], 2];
Graphics[Line /@ grid]

Answer 6

There is a resource function that makes hexagonal graphs: HexagonalGridGraph. (Contributed by WRI.)

Answer 7

Looks like there's an undocumented function GraphComputation`HexagonalGridGraph. I don't know what version it first appeared, but I see it in V13.3:

GraphComputation`HexagonalGridGraph[{10, 6}]