# [GIF] Symmetric Minimality (symmetric lattice trefoil knot)

Posted 10 months ago
1380 Views
|
3 Replies
|
4 Total Likes
|
 Symmetric MinimalityAfter I posted Minimal on Mathstodon, David Eppstein asked about and then found a minimal lattice trefoil with 3-hedral symmetry.Here are the (mean-centered) vertices: symmetrictrefoil = # - Table[Mean[#], {Length[#]}] &[{{0, 0, 0}, {1, 0, 0}, {2, 0, 0}, {2, 0, 1}, {2, 1, 1}, {2, 2, 1}, {1, 2, 1}, {0, 2, 1}, {-1, 2, 1}, {-1, 2, 0}, {-1, 2, -1}, {-1, 1, -1}, {0, 1, -1}, {1, 1, -1}, {1, 1, 0}, {1, 1, 1}, {1, 1, 2}, {1, 2, 2}, {1, 3, 2}, {0, 3, 2}, {0, 3, 1}, {0, 3, 0}, {0, 2, 0}, {0, 1, 0}}]; The animation demonstrates the 3-fold symmetry which is lacking from the relatively asymmetric minimal trefoil from Minimal (which was just the one built into KnotPlot). smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4; DynamicModule[{p = {-1, 0, 0}, q = Normalize[{0, 1, 1}], a, b, n, M, pl, θ, cols = RGBColor /@ {"#404b69", "#f73859", "#283149"}}, Manipulate[ θ = 2 π/3 smootheststep[t]; {n, b} = RotationMatrix[θ, {-1, -1, 1}].# & /@ {p, q}; a = Cross[b, n]; M = {a, b}; pl = M.# & /@ symmetrictrefoil; Graphics[{ Thickness[.0052], cols[[1]], Line[Append[#, First[#]] &[pl]], cols[[2]], Disk[M.#, .05] & /@ Sort[symmetrictrefoil, n.#1 > n.#2 &]}, ImageSize -> 540, PlotRange -> {{-2.75, 2.75}, {-2.5, 3}}, Background -> cols[[-1]]], {t, 0, 1}] ] 
3 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!
 I modified your code a little bit, but qualitatively it still gives a nice result: st = AnglePath3D[{-1/2, -3/2, -1/2}, {{0, 0}, {0, 0}, {0, -π/2}, {π/2, 0}, {0, 0}, {0, -π/2}, {0, 0}, {0, 0}, {π/2, 0}, {0, 0}, {0, -π/2}, {π/2, 0}, {0, 0}, {0, -π/2}, {0, 0}, {0, 0}, {π/2, 0}, {0, 0}, {0, -π/2}, {π/2, 0}, {0, 0}, {0, -π/2}, {0, 0}}]; DynamicModule[{p = {-1, 0, 0}, q = Normalize[{0, 1, 1}], b, n, M, pl, cols = RGBColor /@ {"#404b69", "#f73859", "#283149"}}, Manipulate[{n, b} = {p, q}.RotationMatrix[-2 π/3 t^3/(1 - 3 t + 3 t^2), {-1, -1, 1}]; M = Transpose[{Cross[b, n], b}]; pl = st.M; Graphics[{{EdgeForm[Directive[Thickness[.0052], cols[[1]]]], FaceForm[], Polygon[pl]}, {cols[[2]], Disk[#, .05] & /@ (SortBy[st, -n.# &].M)}}, ImageSize -> 540, PlotRange -> {{-2.75, 2.75}, {-2.5, 3}}, Background -> cols[[-1]]], {t, 0, 1}]] 
 Huh. AnglePath3D[] is a new one to me (in fact, it doesn't even exist on my laptop, which is still on 11.0.1).