# [GIF] BCC (Minimal figure-eight knot on the body-centered cubic lattice)

Posted 1 year ago
2767 Views
|
4 Replies
|
7 Total Likes
| BCCContinuing in the basic theme of Minimal and Symmetric Minimality, but now with the figure-eight knot on the body-centered cubic lattice rather than the trefoil knot on the simple cubic lattice. To make this, I grabbed the coordinates of a (purportedly?) minimal figure-eight knot on the body-centered cubic lattice from Andrew Rechnitzer's page: bcc41 = # - Table[Mean[#], {Length[#]}] &@ Import["https://www.math.ubc.ca/~andrewr/knots/data/BCC41.dat"] After some fooling around to find nice symmetries of this particular embedding of the figure-eight, I came up with the animation, which alternates between viewing along the $x$-axis and along the $z$-axis, as usual using the smoothesttep function for smooth stops and starts. smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4; DynamicModule[{p, q, a, b, n, M, ?, pl, cols = RGBColor /@ {"#eeeeee", "#222831"}}, Manipulate[ ? = (? - ArcCot[Sqrt[1/17 (23 - 16 Sqrt)]]) smootheststep[Mod[t, 1]]; Which[t < 1 || t == 2, {p, q} = {{-1, 0, 0}, Normalize[{0, 1, 1}]}; {n, b} = RotationMatrix[-?, {-1, -1 - Sqrt, 1}].# & /@ {p, q};, 1 <= t < 2, {p, q} = {{0, 0, 1}, {1, 0, 0}}; {n, b} = RotationMatrix[-?, {1, -1 - Sqrt, 1}].# & /@ {p, q}; ]; a = Cross[b, n]; M = {a, b}; pl = M.# & /@ bcc41; Graphics[{ EdgeForm[Directive[Thickness[.01], JoinForm["Round"], cols[]]], FaceForm[None], Polygon[pl], FaceForm[cols[]], Disk[#, .1] & /@ pl}, ImageSize -> 540, PlotRange -> 3, Background -> cols[[-1]]], {t, 0, 2}] ] Answer
4 Replies
Sort By:
Posted 1 year 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! Answer
Posted 1 year ago
 With a little tweaking: bcc41 = Standardize[Import["https://www.math.ubc.ca/~andrewr/knots/data/BCC41.dat"], Mean, 1 &]; DynamicModule[{b, n, pl, ?, cols = RGBColor /@ {"#eeeeee", "#222831"}}, Manipulate[? = (? - ArcTan[Sqrt[23 + 16 Sqrt]]) (#^3/(1 - 3 # (1 - #))) &[Mod[t, 1]]; {n, b} = Which[t < 1 || t == 2, {{-1, 0, 0}, Normalize[{0, 1, 1}]}. RotationMatrix[?, {-1, -1 - Sqrt, 1}], 1 <= t < 2, {{0, 0, 1}, {1, 0, 0}}. RotationMatrix[?, {1, -1 - Sqrt, 1}]]; pl = bcc41.Transpose[{Cross[b, n], b}]; Graphics[{EdgeForm[Directive[Thickness[.01], JoinForm["Round"], cols[]]], FaceForm[], Polygon[pl], FaceForm[cols[]], Disk[#, .1] & /@ pl}, ImageSize -> 540, PlotRange -> 3, Background -> cols[[-1]]], {t, 0, 2}]] Answer
Posted 1 year ago
 Oh, nice! I never knew about Standardize[]. Very useful!I also really like your $t \mapsto \frac{t^3}{1-3t(1-t)}$ function for smooth interpolation. Answer
Posted 1 year ago
 I've found myself using Standardize[] a lot for "centering" operations; glad you think it's neat, too.As for that rational function: I came up with "rational smoothstep" some time back, but this may be the first time I exhibited it in code I have shown publicly. That being said, I'm sure I'm not the first one to come up with using a rational Hermite interpolant for tasks like these. Answer