Issue Plotting Torus Link
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
Note that relatively prime things are single connected loops (as Wikipedia suggests they should be)
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]
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, ∞}]