Message Boards Message Boards

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

Minimal figure-eight knot on the body-centered cubic lattice

BCC

Continuing 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[
  θ = (Pi - ArcCot[Sqrt[1/17 (23 - 16 Sqrt[2])]]) smootheststep[Mod[t, 1]];
  Which[t < 1 || t == 2,
   {p, q} = {{-1, 0, 0}, Normalize[{0, 1, 1}]};
   {n, b} = RotationMatrix[-θ, {-1, -1 - Sqrt[2], 1}].# & /@ {p, q};,
   1 <= t < 2,
   {p, q} = {{0, 0, 1}, {1, 0, 0}};
   {n, b} = RotationMatrix[-θ, {1, -1 - Sqrt[2], 1}].# & /@ {p, q};
   ];
  a = Cross[b, n];
  M = {a, b};
  pl = M.# & /@ bcc41;
  Graphics[{
    EdgeForm[Directive[Thickness[.01], JoinForm["Round"], cols[[1]]]],
     FaceForm[None], Polygon[pl],
    FaceForm[cols[[1]]], Disk[#, .1] & /@ pl},
   ImageSize -> 540, PlotRange -> 3, Background -> cols[[-1]]],
  {t, 0, 2}]
 ]
4 Replies
Posted 6 years 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[θ = (Pi - ArcTan[Sqrt[23 + 16 Sqrt[2]]])
                                       (#^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[2], 1}],
                                        1 <= t < 2,
                                        {{0, 0, 1}, {1, 0, 0}}.
                                        RotationMatrix[θ, {1, -1 - Sqrt[2], 1}]];
                         pl = bcc41.Transpose[{Cross[b, n], b}];
                         Graphics[{EdgeForm[Directive[Thickness[.01],
                                                      JoinForm["Round"], cols[[1]]]], 
                                   FaceForm[], Polygon[pl],
                                   FaceForm[cols[[1]]], Disk[#, .1] & /@ pl},
                                  ImageSize -> 540, PlotRange -> 3, 
                                  Background -> cols[[-1]]], {t, 0, 2}]]
POSTED BY: J. M.

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.

Posted 6 years 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.

POSTED BY: J. M.

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 BY: EDITORIAL BOARD
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