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

Posted 10 months ago
1764 Views
|
3 Replies
|
11 Total Likes
|
 Home on the RangeContinuing 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
Sort By:
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}]] 
 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"}