5
$\begingroup$

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

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 kagome with traingular geometry

Any help or advice is highly appreciated.

$\endgroup$
4
$\begingroup$

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}]
| improve this answer | |
$\endgroup$
  • $\begingroup$ Nice and clean, thanks! $\endgroup$ – Galilean Dec 26 '19 at 5:10
  • 1
    $\begingroup$ 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] & $\endgroup$ – Searke Dec 26 '19 at 16:18
3
$\begingroup$
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]]

enter image description here

kagomeGraph[][33, ImageSize -> Large, 
 EdgeShapeFunction -> ({CapForm["Round"], Line@#} &), 
 BaseStyle -> AbsoluteThickness[3], VertexSize -> Large, 
 VertexStyle -> Yellow]

enter image description here

| improve this answer | |
$\endgroup$
2
$\begingroup$

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

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.