10
$\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?

Improve this question
$\endgroup$
1
  • 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, 2018 at 8:09

3 Answers 3

Reset to default
7
$\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

Improve this answer
$\endgroup$
9
$\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)

Improve this answer
$\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

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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