[GIF] Master Control Program (Minimal 7_4 knot on the simple cubic lattice)

Staff Picks
, , ,
1

l7410q.gif

Master Control Program

Continuing the series of minimal lattice knots ( 1 , 2 , 3 , 4 ), but now back to the simple cubic lattice with the 7_4 knot (a.k.a. the endless knot from Buddhism). Here’s a more standard view of the 7_4:

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

74.jpg
74.jpg959×467 72.1 KB

Once again, we’re grabbing the coordinates of this minimal lattice knot from Andrew Rechnitzer’s page and mean-centering:

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

To get the background gradient I’m using RadialGradientImage, which renders very slowly. If you want a responsive Manipulate, delete the Overlay and the RadialGradientImage, and in the Graphics replace Background -> None with Background -> cols[[-2]].

DynamicModule[{p, q, b, n, θ, pl, 
  cols = RGBColor /@ {"#cdffeb", "#009f9d", "#07456f", "#0f0a3c"}},
 Manipulate[
  θ = ArcCos[-(1/3)] (#^3/(1 - 3 # (1 - #))) &[Mod[t, 1]];
  Which[t < 1 || t == 4,
   {p, q} = Normalize /@ {{1, 1, 1}, {1, 0, -1}};
   {n, b} = {p, q}.RotationMatrix[-θ, {-1, 0, 1}];,
   1 <= t < 2,
   {p, q} = Normalize /@ {{-1, 1, -1}, {1, 0, -1}};
   {n, b} = {p, q}.RotationMatrix[-θ, {0, 1, 1}];,
   2 <= t < 3,
   {p, q} = Normalize /@ {{-1, -1, 1}, {-1, 0, -1}};
   {n, b} = {p, q}.RotationMatrix[- θ, {1, 0, 1}];,
   3 <= t < 4,
   {p, q} = Normalize /@ {{1, -1, -1}, {-1, 0, -1}};
   {n, b} = {p, q}.RotationMatrix[- θ, {0, -1, 1}];
   ];
  pl = sc74.Transpose[{Cross[b, n], b}];
  Overlay[
   {RadialGradientImage[cols[[2 ;;]], {540, 540}],
    Graphics[
     {EdgeForm[
       Directive[Thickness[.025], JoinForm["Round"], cols[[1]]]], 
      FaceForm[None], Polygon[pl]},
     ImageSize -> 540, PlotRange -> 4, Background -> None]}
   ],
  {t, 0, 4}]
 ]
4 Likes
2

Since the background is a fixed thing and not being actively updated, you can put the initialization in DynamicModule[]; thus, you can do something like

DynamicModule[{p, q, b, n, θ, pl, col = RGBColor["#cdffeb"], 
               bg = RadialGradientImage[RGBColor /@ {"#009f9d", "#07456f", "#0f0a3c"},
                                        {540, 540}]},
Manipulate[(* stuff *)
           Overlay[{bg, Graphics[{EdgeForm[Directive[Thickness[.025],
                                                     JoinForm["Round"], col]],
                                  FaceForm[], Polygon[pl]},
                   ImageSize -> 540, PlotRange -> 4]}], {t, 0, 4}]]

Yet another alternative that avoids Overlay[] would be to use a textured polygon as background. To do that, you can replace the last line inside the Manipulate[] with

Graphics[(* stuff *), ImageSize -> 540, PlotRange -> 4, 
         Prolog -> {Texture[bg], 
                    Polygon[{Scaled[{0, 0}], Scaled[{1, 0}],
                             Scaled[{1, 1}], Scaled[{0, 1}]}, 
                            VertexTextureCoordinates ->
                            {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}]
4 Likes
3

2015-11-02_10-07-11.png