Given an array of atoms A-B-A-B-A-B in an hexagonal pattern, how can I use Mathematica to create with an hexagonal lattice (infinite) with this array so each atom A is sorrounded only by B atoms and vice-versa.
-
1$\begingroup$ Hola Jose, welcome to Mathematica.SE. Do you mean graphical lattice, a plot necessarily finite, or an analytical description of a lattice? Probably you could give more details of what do you intend to do with that, so its easier to help you. $\endgroup$– rhermansOct 11, 2014 at 10:04
-
$\begingroup$ a finite lattice given by an hexagonal pattern with 2 atoms for example like this google.es/… but with 2 atoms instead one (graphene) $\endgroup$– Jose Javier GarciaOct 11, 2014 at 10:14
-
$\begingroup$ Related: 19165 , 14632. $\endgroup$– rhermansOct 11, 2014 at 12:45
-
1$\begingroup$ Also related: Wolfram Demo $\endgroup$– JensOct 11, 2014 at 16:41
-
$\begingroup$ Some knowledge of Solid State Physics facilitates it. $\endgroup$– Αλέξανδρος ΖεγγDec 19, 2017 at 3:16
4 Answers
In 2D
unitCell[x_, y_] := {
Red
, Disk[{x, y}, 0.1]
, Blue
, Disk[{x, y + 2/3 Sin[120 Degree]}, 0.1]
, Gray,
, Line[{{x, y}, {x, y + 2/3 Sin[120 Degree]}}]
, Line[{{x, y}, {x + Cos[30 Degree]/2, y - Sin[30 Degree]/2}}]
, Line[{{x, y}, {x - Cos[30 Degree]/2, y - Sin[30 Degree]/2}}]
}
This creates the unit cell
Graphics[unitCell[0, 0], ImageSize -> 100]
We place it into a lattice
Graphics[
Block[
{
unitVectA = {Cos[120 Degree], Sin[120 Degree]}
,unitVectB = {1, 0}
}, Table[
unitCell @@ (unitVectA j + unitVectB k)
, {j, 1, 12}
, {k, Ceiling[j/2], 20 + Ceiling[j/2]}
]
], ImageSize -> 500
]
In 3D
unitCell3D[x_, y_, z_] := {
Red
, Sphere[{x, y, z}, 0.1]
, Blue
, Sphere[{x, y + 2/3 Sin[120 Degree], z}, 0.1]
, Gray
, Cylinder[{{x, y, z}, {x, y +2/3 Sin[120 Degree], z}}, 0.05]
, Cylinder[{{x, y, z}, {x + Cos[30 Degree]/2, y - Sin[30 Degree]/2,
z}}, 0.05]
, Cylinder[{{x, y, z}, {x - Cos[30 Degree]/2, y - Sin[30 Degree]/2,
z}}, 0.05]
}
Graphics3D[
Block[
{unitVectA = {Cos[120 Degree], Sin[120 Degree], 0},
unitVectB = {1, 0, 0}
},
Table[unitCell3D @@ (unitVectA j + unitVectB k), {j, 20}, {k, 20}]]
, PlotRange -> {{0, 10}, {0, 10}, {-1, 1}}
]
-
-
1$\begingroup$ Great answer, liked considering both 2d and 3d! $\endgroup$– VividDOct 19, 2014 at 10:48
In 2D,
Manipulate[(
basis = {{s, 0}, {s/2, s Sqrt[3]/2}};
points = Tuples[Range[0, max], 2].basis;
Graphics[Point[points], Frame -> True, AspectRatio -> Automatic])
, {s, 0.1, 1}
, {max, 2, 10}
]
Another way is to use GeometricTransformation
, which might render faster, but is limited by $IterationLimit
.
With[{base = Line[{
{{-(1/2), -(1/(2 Sqrt[3]))}, {0, 0}},
{{0, 0}, {0, 1/Sqrt[3]}},
{{0, 0}, {1/2, -(1/(2 Sqrt[3]))}}
}]
},
Graphics[{
GeometricTransformation[
base,
Flatten@Array[
TranslationTransform[
{1/2, -(1/(2 Sqrt[3]))} + {#1 +
If[OddQ[#2], 1/2, 0], #2 Sqrt[3]/2}
] &,
{16, 16}
]
]
}]
]
This does not work without increasing $IterationLimit
when you replace {16, 16}
by {128, 128}
.
There are few resource functions that can help for making hexagonal grids. The code below is from the examples of HextileBins
.
HextileBins
hexes2 = Keys[
ResourceFunction["HextileBins"][
Flatten[Table[{x, y}, {x, 0, 16}, {y, 0, 12}], 1], 2]];
Graphics[{EdgeForm[Blue], FaceForm[Opacity[0.1]], hexes2}]
lsBCoords = Union[Flatten[First /@ hexes2, 1]];
Graphics[{EdgeForm[Blue],
hexes2 /. Polygon[p_] :> Line[Append[p, First[p]]], Red,
PointSize[0.02], Point[lsBCoords]}]
HexagonalGridGraph
(Note that this function is submitted by Wolfram Research.)
grHex = ResourceFunction["HexagonalGridGraph"][{16, 12}]
lsVCoords = GraphEmbedding[grHex];
lsVCoords[[1 ;; 12]]
(* {{0, 0}, {0, 2}, {Sqrt[3], -1}, {Sqrt[3], 3}, {2 Sqrt[3], 0}, {Sqrt[
3], 5}, {2 Sqrt[3], 2}, {2 Sqrt[3], 6}, {3 Sqrt[3], -1}, {3 Sqrt[3],
3}, {2 Sqrt[3], 8}, {3 Sqrt[3], 5}} *)
grHexPolygons =
Map[Polygon@(List @@@ #)[[All, 1]] &,
FindCycle[grHex, {6, 6}, All]] /. v_Integer :> lsVCoords[[v]];
Graphics[{EdgeForm[Blue], FaceForm[Opacity[0.2]], grHexPolygons}]