8
$\begingroup$

I'm having an issue plotting torus links in Mathematica. What I'm trying to generate is a (2,8) torus link like the one in the picture in Wikipedia:

2,8 torus link

using equations such as those outlined here.

However, I appear to only get half of the respective torus link.

a = 1; d = 4; p = 2; q = 8;
ParametricPlot3D[{(a*Sin[q*t] + d)*Sin[p*t], (a*Sin[q*t] + d)*
Cos[p*t], a*Cos[q*t]}, {t, 0, 2*Pi}, PlotStyle -> Orange, 
PlotRange -> All] /. Line[pts_, rest___] :> Tube[pts, 0.2, rest]

my attempt

(a and d are parameters that control the width of the tube and the distance of the curve from the origin respectively, outlined here.)

Can anyone explain why I am only seeing half of the link?

$\endgroup$
  • 2
    $\begingroup$ You're only plotting one set of parametric equations and you can see in the image that you don't expect there to be any intersections so the smooth parametric equations clearly can't generate the structure you want. On the other hand, it ought to be clear that the others may be generated via a simple rotation in the x-y plane. $\endgroup$ – b3m2a1 Aug 2 '18 at 8:09
6
$\begingroup$

The second torus is created by a rotation of $\pi/4$ (around {0, 0, 1}):

R = RotationMatrix[Pi/4, {0, 0, 1}];
torus = {(a*Sin[q*t] + d)*Sin[p*t], (a*Sin[q*t] + d)*Cos[p*t], a*Cos[q*t]};
ParametricPlot3D[{torus, R.torus} // Evaluate, {t, 0, 2*Pi}, PlotStyle -> {Orange, Blue}, PlotRange -> All] 

Knot

$\endgroup$
8
$\begingroup$

Here's I think a generalization of what Ulrich gave to an arbitrary $(p, q)$ torus (if I read Wikipedia right):

plotPQTorus[{p_, q_}, a : _?NumericQ : 1, d : _?NumericQ : 4, 
  ops : OptionsPattern[]] :=
 Block[{t},
  ParametricPlot3D[
    Evaluate@
     Table[
      RotationMatrix[
        i*2 \[Pi]/q, {0, 0, 1}].{(a*Sin[q*t] + d)*
         Sin[p*t], (a*Sin[q*t] + d)*Cos[p*t], a*Cos[q*t]},
      {i, 0, If[Divisible[q, p], p - 1, 0]}
      ],
    {t, 0, 2*Pi},
    PlotRange -> All,
    ops
    ] /. Line[pts_, rest___] :> Tube[pts, 0.2, rest]
  ]

Here are a few plots:

Table[plotPQTorus[{p, Fibonacci[q]}, Boxed -> False, 
   Axes -> None], {p, 1, 4}, {q, 2, 6, 2}] // Grid

enter image description here

Note that relatively prime things are single connected loops (as Wikipedia suggests they should be)

$\endgroup$
4
$\begingroup$

The (1,4) torus knot is known to KnotData[], so we can use that to build the (2,8) knot:

knot14 = First[KnotData[{"TorusKnot", {1, 4}}, "ImageData"]];

Graphics3D[MapThread[Insert[##, {2, 1}] &,
                     {{knot14, MapAt[RotationTransform[π/4, {0, 0, 1}], knot14, {1}]}, 
                      Directive[Specularity[1, 10], #] & /@ {Blue, Red}}], 
           Boxed -> False, Lighting -> "Neutral", ViewPoint -> {0, 0, ∞}]

(2,8) knot

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.