10
$\begingroup$

I'm currently trying to draw tubular neighborhoods of torus knots, which Mathematica's Tube function allows me to do quite easily. My question regards the appearance of the neighborhood: is there any way to use an explicit function to continuously specify the radius of the tube? I've managed to find a few examples with nonconstant radii, but nothing where it varies continuously.

I did manage to find enough examples to figure out how draw these tubular neighborhoods so that they are colored according to an explicit function. If possible, I would like the radius to correspond to the color at every point on the curve. Here's what I've got so far:

Clear[γ, t, w, wColor, wmin, wmax]

(*Define a torus knot γ and a weight function w*)
γ[t_] = {(2 + Cos[3 t]) Cos[2 t], (2 + Cos[3 t]) Sin[2 t], Sin[3 t]};
w[t_] = 2 + Cos[t];

(*All this nonsense makes red the heaviest and blue the lightest*)
wmin = First[FindMinimum[{w[t], 0 <= t <= 2 π}, {t, .1}]];
wmax = First[FindMaximum[{w[t], 0 <= t <= 2 π}, {t, .1}]];
wColor[t_] = (7/10)*(1 - ((w[t] - wmin)/(wmax - wmin)));

ParametricPlot3D[γ[t], {t, 0, 2 π + .01}, 
   ColorFunction -> Function[{x, y, z, t}, Hue[wColor[t]]], 
   ColorFunctionScaling -> False, 
   PlotStyle -> Directive[Opacity[.7], CapForm[None]], 
   PlotRange -> All, Boxed -> False, 
   MaxRecursion -> 0, 
   PlotPoints -> 100, 
   Axes -> None, 
   Method -> {"TubePoints" -> 30}] /. 
   Line[pts_, rest___] -> Tube[pts, 0.2, rest]

In short, I would like to continuously vary the radius of this tube:

colored tube

$\endgroup$
1
  • $\begingroup$ I did something like that here. $\endgroup$
    – Jens
    Jan 26, 2016 at 1:10

2 Answers 2

11
$\begingroup$

You can take a continuous function and evaluate it at the same points that are also used by ParametricPlot3D to create the curve. Here is a way to do it:

rr = Reap[
   ParametricPlot3D[γ[t], {t, 0, 2 Pi + .01}, 
    ColorFunction -> 
     Function[{x, y, z, t}, Hue[wColor[Sow[t, "tValues"]]]], 
    ColorFunctionScaling -> False, 
    PlotStyle -> Directive[Opacity[.7], CapForm[None]], 
    PlotRange -> All, Boxed -> False, MaxRecursion -> 0, 
    PlotPoints -> 100, Axes -> None, Method -> {"TubePoints" -> 30}], 
   "tValues"];
rr[[1]] /. 
 Line[pts_, rest___] :> Tube[pts, 0.2 + .1 Sin[rr[[2]]], rest]

plot

Here I chose a Sin[t] variation of the thickness. To do it, I collect the evaluation points from inside ParametricPlot3D using Sow and Reap.

This list of points is in rr[[2]], whereas rr[[1]] is the plot itself. Then I modify the replacement rule you already had by making the radii of Tube into a list obtained by applying the desired continuous function to rr[[2]].

$\endgroup$
2
  • $\begingroup$ Again, thank you so much for helping me with this. It has had a tremendous impact on my ability to communicate my research effectively. $\endgroup$ Aug 28, 2016 at 3:35
  • 1
    $\begingroup$ @AegisCruiser Glad to hear it. Looking at my solution, it's better to use :> (RuleDelayed) instead of -> in the last step where tube is introduced. It won't matter as long as pts and rest are undefined globally, but :> insures that things won't break even if pts has a value before it is used as the replacement pattern. $\endgroup$
    – Jens
    Aug 28, 2016 at 4:46
5
$\begingroup$

Another possibility for making a tube with continuously varying width from a space curve is to compute the normal and binormal vectors of the curve with FrenetSerretSystem[], which can then be used to assemble the parametric equations of the tube surface. (In general this can fail, but it will work for torus knots).

γ[t_] := {(2 + Cos[3 t]) Cos[2 t], (2 + Cos[3 t]) Sin[2 t], Sin[3 t]};
w[t_] := 2 + Cos[t];

(* normal and binormal vectors *)
{no[t_], bi[t_]} = FrenetSerretSystem[γ[t], t][[-1, {2, 3}]];

ParametricPlot3D[γ[t] + (w[π/2 - t]/10) {Cos[u], Sin[u]}.{no[t], bi[t]},
                 {t, 0, 2 π}, {u, 0, 2 π}, Axes -> None, Boxed -> False, 
                 ColorFunction -> Function[{x, y, z, t}, Hue[1 - w[t]/3, 1, 1, 0.7]], 
                 ColorFunctionScaling -> False, Mesh -> False, PlotPoints -> {85, 20},
                 PlotRange -> All]

colored torus knot with varying radius

(Note how I incorporated the opacity information as the fourth parameter in Hue[].)

If one finds the Frenet-Serret computations to be too slow, one can use e.g. Bishop frames (see e.g. this and this) instead, but I will not be discussing them further here.

$\endgroup$
1
  • $\begingroup$ Simplify the expression {no[t_], bi[t_]} make the plot faster. $\endgroup$
    – cvgmt
    Mar 6, 2023 at 13:03

Your Answer

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

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