Message Boards Message Boards

GROUPS:

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

Posted 1 year ago
1859 Views
|
2 Replies
|
7 Total Likes
|

Minimal 7_4 knot on the simple cubic lattice

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"}

Standard Mathematica views of the 7_4 knot

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}]
 ]
2 Replies
Posted 1 year ago

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}}]}]
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!

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