Drawing a Kagome lattice for given geometry

Question

I came across this question in stack exchange. Modified the answer a bit to get a lattice structure like this.

lattice := Block[{},
  unit[i_, j_] := 
    Translate[{{Thickness[t1/300], Red, 
       Line[1/2 {{1/2, Sqrt[3]/2}, {0, 0}, {1, 0}}], 
       Line[{{1/4, Sqrt[3]/4}, {1/2, 0}}], 
       Line[{{1, 0}, {1 + 1/4, Sqrt[3]/4}}], 
       Line[{{1/2, Sqrt[3]/2}, {1, Sqrt [3]/2}}]}, {Thickness[t2/300],
        Blue, Line[{{1, Sqrt[3]/2}, {5/4, Sqrt[3]/4}}], 
       Line[{1/2 {1/2, Sqrt[3]/2}, {1/2, Sqrt[3]/2}}], 
       Line[{{1/2, 0}, {1, 0}}], 
       Line[{{1 + 1/4, Sqrt[3]/4}, {3/2, Sqrt[3]/2}}], 
       Line[{{1, Sqrt [3]/2}, {3/2, Sqrt[3]/2}}]}, {Orange, 
       PointSize[Large], 
       Point[{{0, 0}, {1/4, Sqrt[3]/4}, {1/2, 0}, {1, 0}, {5/4, 
          Sqrt[3]/4}, {3/2, Sqrt[3]/2}, {1/2, Sqrt[3]/2}, {1, 
          Sqrt [3]/2}}]}}, {i + j/2, Sqrt[3]/2 j}];] 
t1=1.1;
t2=1.0;
lattice;
Graphics[Array[unit, {2, 2}]]

Now, I want to do the same thing for triangular geometry like this

Any help or advice is highly appreciated.

score 5 · Accepted Answer · answered Dec 25 '19 at 19:57

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

For some of these tiling problems, it might be helpful to pull the coordinates from the Entity for them: Entity["PeriodicTiling", "TrihexagonalTiling"]["PrimitiveUnit"]// Cases[#, _Polygon, Infinity] & — Searke, Dec 26 '19 at 16:18

score 4 · Answer 2 · answered Dec 30 '19 at 07:04

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]

score 3 · Answer 3 · answered Apr 27 '20 at 13:25

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

kagome triangle

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]

kagome triangle graph

Drawing a Kagome lattice for given geometry

3 Answers3

Linked