Message Boards Message Boards

[GIF] Home on the Range (Rotating minimal 7_7 on the BCC lattice)

Rotating minimal 7_7 on the BCC lattice

Home on the Range

Continuing the series (1, 2, 3), this time with a minimal $7_7$ knot on the body-centered cubic lattice. Instead of viewing the projection of the knot as a bunch of balls connected by sticks, I'm filling it in with a solid color. As per the Polygon conventions, the points in the plane for which any path to the unbounded region crosses the boundary an odd number of times are colored dark purple, and the rest of the points in the plane are colored light grey.

As before, the coordinates are grabbed from Andrew Rechnitzer's site:

bcc77 = Standardize[
   Import["https://www.math.ubc.ca/~andrewr/knots/data/BCC77.dat"], Mean, 1 &];

Thanks to @J. M. for various code improvement suggestions, especially for the function $t \mapsto \frac{t^3}{1-3t(1-t)}$.

DynamicModule[{p, q, b, n, ?, pl, 
  cols = RGBColor /@ {"#621295", "#e3e7f1"}},
 Manipulate[
  ? = 2?/3 (#^3/(1 - 3 # (1 - #))) &[Mod[t, 1]];
  Which[t < 1 || t == 2,
   {p, q} = {{-1, 0, 0}, {0, 0, 1}};
   {n, b} = {p, q}.RotationMatrix[?, {-1, -1, 1}];,
   1 <= t < 2,
   {p, q} = {{0, 0, 1}, {0, -1, 0}};
   {n, b} = {p, q}.RotationMatrix[?, {1, -1, 1}];
   ];
  pl = bcc77.Transpose[{Cross[b, n], b}];
  Graphics[{Thickness[.005], JoinForm["Round"], cols[[1]], 
    CapForm["Round"], Polygon[pl]},
   ImageSize -> 540, PlotRange -> 4, Background -> cols[[-1]]],
  {t, 0, 2}]
 ]
POSTED BY: Clayton Shonkwiler
3 Replies
Sort By:

Wonderful work! So newcomers to knot theory can appreciate deeper your art here are some basic visuals of what $7_7$ knot is:

KnotData[{7, 7}, #] & /@ {"Image", "KnotDiagram"}

enter image description here
POSTED BY: Vitaliy Kaurov

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: Moderation Team
J. M.
J. M.
Posted 5 years ago

Looks nice!

Just to be ornery, I came up with a variation that combines my "rational smoothstep" with spherical linear interpolation ("slerp"):

DynamicModule[{b, n, u, ? = N[2 ?/3] , cols = RGBColor /@ {"#621295", "#e3e7f1"}},
              Manipulate[u = (#^3/(1 - 3 # (1 - #))) &[Mod[t, 1]];
                        {n, b} = Which[t < 1 || t == 2,
                                       {{-1, 0, 0}, {0, 0, 1}} Sin[? (1 - u)] +
                                       {{0, 0, 1}, {0, -1, 0}} Sin[? u],
                                       1 ? t < 2,
                                       {{0, 0, 1}, {0, -1, 0}} Sin[? (1 - u)] +
                                       {{1, 0, 0}, {0, 0, 1}} Sin[? u]]/Sin[?];
                        Graphics[{cols[[1]],
                                  Polygon[bcc77.Transpose[{Cross[b, n], b}]]},
                                  ImageSize -> 540, PlotRange -> 4,
                                  Background -> cols[[-1]]], {t, 0, 2}]]

a variation
POSTED BY: J. M.
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract