Message Boards Message Boards

GROUPS:

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

Posted 10 months ago
1764 Views
|
3 Replies
|
11 Total Likes
|

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}]
 ]
3 Replies
Posted 10 months 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.
Answer

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!

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

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