# [GIF] Minimal (Rotating minimal lattice trefoil knot)

Posted 10 months ago
2441 Views
|
4 Replies
|
12 Total Likes
|
 MinimalThis 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
Sort By:
Posted 10 months ago
 - 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 10 months 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. ;)