Drawing a Kagome lattice for given geometry
Here you are!!!
Kagome[n_, a_, b_] := Module[
{v1, v2, makePoints, makeGrids, grids, triangles},
v1 = {-(1/2), -Sqrt[3]/2}; v2 = {1/2, -Sqrt[3]/2};
makePoints[list_, r_] := Flatten[{# + r v1, # + r v2} & /@ list, 1];
makeGrids[k_, r_] := DeleteDuplicates /@ NestList[makePoints[#, r] &, {{0, 0}}, k];
grids = makeGrids[n, a + b];
triangles = {#, # + a v1, # + a v2} & /@ Flatten[grids, 1];
Graphics[
{
{Black, PointSize[0.02], Point@#} & /@ triangles,
{Red, Line@Append[#, First@#]} & /@ triangles,
{Blue, Line[{#, # - b v1}]} & /@ grids[[2 ;;, 1]], (*right edge*)
{Blue, Line[{#, # - b v2}]} & /@ grids[[2 ;;, -1]], (*left edge*)
{Blue, Line[# + {a v2, a v1}]} & /@ Subsequences[grids[[-1]], {2}], (*bottom edge*)
{Blue, PointSize[0.3], Line[{#, # - b v1, # - b v2, #}]} & /@
Flatten[grids[[2 ;;, 2 ;; -2]], 1] (*middle*)
},
PlotRange -> {(n + 1)*(a + b)*{-1/2, 1/2}, {1, (n + 1)*(a + b)*-(Sqrt[3]/2)}}
]
];
Manipulate[Kagome[n, a, b], {n, 1, 5, 1}, {a, 1, 3}, {b, 1, 3}]
ClearAll[kagomeGraph]
kagomeGraph[color1_: Blue, color2_: Red] := Module[{ig, rededges,
coords = Prepend[Join @@
(Thread[{Range[-#, #, 2][[;; ;; Mod[#, 2, 1]]], -# Sqrt[3]}] & /@ Range[#]), {0, 0}]},
ig = IndexGraph @ NearestNeighborGraph[coords, VertexCoordinates -> coords];
rededges = Join @@ Select[Abs@Differences@Rest@Sort@VertexList@# == {1} &]@
FindCycle[ig, {3}, All];
SetProperty[ig, {EdgeStyle -> {_ -> color1,
Alternatives @@ rededges -> color2}, ##2}]] &;
Examples:
Row[kagomeGraph[][#, ImageSize -> 300,
EdgeShapeFunction -> ({CapForm["Round"], Line@#} &),
BaseStyle -> AbsoluteThickness[12], VertexSize -> Small,
VertexStyle -> White] & /@
Range[3, 9, 2], Spacer[5]]
kagomeGraph[][33, ImageSize -> Large,
EdgeShapeFunction -> ({CapForm["Round"], Line@#} &),
BaseStyle -> AbsoluteThickness[3], VertexSize -> Large,
VertexStyle -> Yellow]
This is a cute problem. Here's my modest attempt:
kagomeTriangle[n_Integer /; n > 1] := Module[{bas, down, hex, mid, up},
bas = Table[{n - k, (n - k) Sqrt[3]} + {j, 0},
{k, n, 1, -1}, {j, 0, 2 k - 1}];
mid = Map[TranslationTransform[{0, Sqrt[3]/2}][Mean /@ Partition[#, 2]] &, bas];
up = MapThread[Polygon[Append[#1, #2]] &,
MapAt[Partition[#, 2] &, #, 1]] & /@ Transpose[{bas, mid}];
hex = Map[Polygon[Flatten[#, 1][[{3, 1, 2, 4, 5, 6}]]] &,
Flatten[{Partition[Delete[#, {{1}, {-1}}], 2] & /@ Most[bas],
Partition[#, 2, 1] & /@ Most[mid],
Reverse[Partition[#, 2], 2] & /@ Rest[bas]},
{{2}, {3}, {1}}], {2}];
down = MapThread[Polygon[Prepend[#2, #1]] &, #] & /@
Transpose[{Delete[#, {{1}, {-1}}] & /@ Drop[mid, -2],
Partition[Delete[#, {{1}, {-1}}], 2] & /@
Delete[bas, {{1}, {-1}}]}];
{down, hex, up}]
Graphics[{FaceForm[],
Transpose[{EdgeForm[Directive[#, AbsoluteThickness[4]]] & /@
{RGBColor["#00AEE6"], RGBColor["#00AEE6"], RGBColor["#E2328F"]},
kagomeTriangle[5]}]}]
If a Graph[]
is desired, the routine above can be slightly modified, like so:
kagomeTriangleGraph[n_Integer /; n > 1, opts___] :=
Module[{bas, e3, e6, facs, hex, mid, msh, up},
bas = Table[{n - k, (n - k) Sqrt[3]} + {j, 0},
{k, n, 1, -1}, {j, 0, 2 k - 1}];
mid = Map[TranslationTransform[{0, Sqrt[3]/2}][Mean /@ Partition[#, 2]] &,
bas];
up = MapThread[Polygon[Append[#1, #2]] &,
MapAt[Partition[#, 2] &, #, 1]] & /@
Transpose[{bas, mid}];
hex = Map[Polygon[Flatten[#, 1][[{3, 1, 2, 4, 5, 6}]]] &,
Flatten[{Partition[Delete[#, {{1}, {-1}}], 2] & /@ Most[bas],
Partition[#, 2, 1] & /@ Most[mid],
Reverse[Partition[#, 2], 2] & /@ Rest[bas]},
{{2}, {3}, {1}}], {2}];
msh = DiscretizeGraphics[{hex, up}];
facs = GroupBy[MeshCells[msh, 2][[All, 1]], Length];
e3 = Flatten[Map[Sort, Partition[#, 2, 1, 1]] & /@ facs[3], 1];
e6 = Complement[Flatten[Map[Sort, Partition[#, 2, 1, 1]] & /@
facs[6], 1], e3];
Graph[Join[Style[UndirectedEdge @@ #,
Directive[AbsoluteThickness[4], RGBColor["#E2328F"]]] &
/@ e3,
Style[UndirectedEdge @@ #,
Directive[AbsoluteThickness[4], RGBColor["#00AEE6"]]] &
/@ e6],
opts,
VertexCoordinates -> MapIndexed[First[#2] -> #1 &,
MeshCoordinates[msh]],
VertexShapeFunction -> "Circle",
VertexStyle -> Directive[ColorData["Legacy", "MintCream"],
EdgeForm[Opacity[1/2, Gray]]]]]
For example,
kagomeGraph[5, VertexSize -> Medium]