Message Boards Message Boards

GROUPS:

[GIF] Minimal (Rotating minimal lattice trefoil knot)

Posted 1 month ago
880 Views
|
4 Replies
|
12 Total Likes
|

Rotating minimal lattice trefoil knot

Minimal

This shows the trefoil knot lying on the simple cubic lattice with the fewest possible number of edges (it's a theorem of Yuanan Diao that the lattice stick number of the trefoil is 24), rotated, and projected to the plane.

The 3D vertex locations are in KnotPlot. At least in the MacOS version of KnotPlot, the data is contained in the app bundle at /Applications/KnotPlot/KnotPlot.app/Contents/Resources/special/mscl/3.1; if you don't have KnotPlot installed, you can download the data by going to https://knotplot.com/download/ and clicking the link to download kpdist.tar.gz. If you do that and then unzip to get a directory called kpsdist, the following commands will import the vertices and mean center:

lattice31 = Import["kpdist/special/mscl/3.1", "Table"];
lattice31 = lattice31 - Table[Mean[lattice31], {Length[lattice31]}];

As usual for animations where I want to smoothly stop and start a motion, I'm going to use the smootheststep function:

smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;

Here, then, is the Manipulate for the above animation (the giant obnoxious Which is to switch between different axis rotations, which I obviously could have made a little cleaner with some extra work):

DynamicModule[{p, q, a, b, n, M, θ, pl, 
  cols = RGBColor /@ {"#fd5f00", "#05004e", "#fbfaf1"}},
 Manipulate[
  Which[t < 1 || t == 4,
   {p, q} = RotationMatrix[ArcTan[1/Sqrt[2]]].{Normalize[{1, 1, 0}], {0, 0, 1}};
   θ = -(ArcTan[1/Sqrt[2]] + π/2) smootheststep[Mod[t, 1]];
   {n, b} = RotationMatrix[θ].{p, q};,
   1 <= t < 2,
   {p, q} = {{0, 0, 1}, {-(1/Sqrt[2]), -(1/Sqrt[2]), 0}};
   θ = (π - ArcTan[Sqrt[23 - 16 Sqrt[2]]]) smootheststep[Mod[t, 1]];
   {n, b} = RotationMatrix[-θ, 
        N@{Sqrt[1/17 (5 + 2 Sqrt[2])], Sqrt[1/17 (7 - 4 Sqrt[2])], 
          Root[1 - 10 #1^2 + 17 #1^4 &, 1]}].# & /@ {p, q};,
   2 <= t < 3,
   {p, q} = {{-1, 0, 0}, {0, 0, 1}};
   θ = 3 π/4 smootheststep[Mod[t, 1]];
   {n, b} = RotationMatrix[θ].{p, q},
   3 <= t,
   {p, q} = {{1/Sqrt[2], 0, -(1/Sqrt[2])}, {-(1/Sqrt[2]), 0, -(1/Sqrt[2])}};
   θ = (π - ArcCot[(3 - 2 Sqrt[2] + 2 Sqrt[3] + Sqrt[6])/Sqrt[
        13 - 4 Sqrt[3] + 2 Sqrt[6]]]) smootheststep[Mod[t, 1]];
   {n, b} = RotationMatrix[-θ, 
        N@{Root[1 - 156 #1^2 + 1670 #1^4 - 5148 #1^6 + 4801 #1^8 &, 
           1], Root[1 - 52 #1^2 + 870 #1^4 - 5044 #1^6 + 4801 #1^8 &, 
           2], (2 + Sqrt[2])/Sqrt[
          94 - 48 Sqrt[2] + 48 Sqrt[3] - 32 Sqrt[6]]}].# & /@ {p, q};
   ];
  a = Cross[b, n];
  M = {a, b};
  pl = M.# & /@ lattice31;
  Graphics[
   {Thickness[.004], cols[[1]], Line[Append[#, First[#]] &[pl]],
    FaceForm[cols[[-1]]], 
    EdgeForm[Directive[Thickness[.004], cols[[2]]]],
    Disk[M.#, .05] & /@ Sort[lattice31, n.#1 > n.#2 &]},
   ImageSize -> 540, PlotRange -> 2.2, Background -> cols[[-1]]],
  {t, 0, 4}]
 ]
4 Replies

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

Posted 1 month ago

For people who don't want to download software just to get the needed points for the knot:

lattice31 = AnglePath3D[{19/24, 4/3, 11/8},
                        {{0, π/2}, {0, 0}, {-π/2, 0}, {0, π/2}, {0, 0}, {0, -π/2},
                         {-π/2, 0}, {π/2, 0}, {0, -π/2}, {0, 0}, {0, -π/2}, {0, 0},
                         {0, -π/2}, {0, π/2}, {π/2, 0}, {0, 0}, {π/2, 0}, {0, 0},
                         {π/2, 0}, {0, 0}, {0, 0}, {0, π/2}, {π/2, 0}}];

As for the main code itself: the standard advice of replacing M.# & /@ pts with pts.Transpose[M] and RotationMatrix[-θ, axis].# & /@ {p, q} with {p, q}.RotationMatrix[θ, axis] applies. ;)

POSTED BY: J. M.
Answer

As for the main code itself: the standard advice of replacing M.# & /@ pts with pts.Transpose[M] and RotationMatrix[-θ, axis].# & /@ {p, q} with {p, q}.RotationMatrix[θ, axis] applies. ;)

Yeah, I know. I think I've never quite accepted the reality that individual vectors may as well be column vectors (in terms of how matrix multiplication works), but vectors in lists are definitely row vectors.

Posted 1 month ago

For better or for worse, Mathematica's matrices (or list of lists, however your preference) are row-oriented. I admit that it also took me some time to adjust my conventional mental images of linear algebra to adapt them to programming in Mathematica.

POSTED BY: J. M.
Answer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract