How do I plot the desired phase space diagram with an iron cables-like structure?

Question

I want to plot the phase space diagram of the Lorenz attractor shown below on the top figure; however, I can only plot the bottom figure in Mathematica.

phase = Block[{a = 10.0, b = 28.0, c = 8/3}, 
   NDSolve[{x'[t] == a*(y[t] - x[t]), y'[t] == x[t]*(b - z[t]) - y[t],
      z'[t] == x[t]*y[t] - c*z[t], x[0] == 10.0, y[0] == 10.0, 
     z[0] == 10.0}, {x, y, z}, {t, 0, 1000, 0.001}, 
    Method -> "ExplicitRungeKutta", MaxSteps -> \[Infinity]]];
ParametricPlot3D[{x[t], y[t], z[t]} /. phase, {t, 950, 1000}, 
 PlotRange -> All, PerformanceGoal -> "Quality", Boxed -> False, 
 Axes -> False]

How do I plot the desired phase space diagram with an iron cables-like structure?

Answer 1

• Tube can not do the non-convex cross-section as in the picture show.

• Here we try to post an example for small c1,c2, so it is just a staring point.

• We rewrite the code from https://mathematica.stackexchange.com/a/169836/72111 and use * as the cross-section.

Clear["Global`*"];
c1 = 0; c2 = 5; phase = 
 Block[{a = 10.0, b = 28.0, c = 8/3}, 
  NDSolve[{x'[t] == a*(y[t] - x[t]), y'[t] == x[t]*(b - z[t]) - y[t], 
    z'[t] == x[t]*y[t] - c*z[t], x[0] == 10.0, y[0] == 10.0, 
    z[0] == 10.0}, {x, y, z}, {t, c1, c2, 0.001}, 
   Method -> "ExplicitRungeKutta", MaxSteps -> ∞]];
γ[t_] := {x@t, y@t, z@t} /. phase[[1]];
T[t_] = Normalize[γ'[t]];
κ[t_] = (γ''[t] - (γ''[t] . T[t])  T[t])/
   Norm[γ'[t]]^2;
t0 = 0;
T0 = T[t0];
{B0, N0} = Normalize /@ Orthogonalize@HodgeDual[T[t0]] // Most;
{nframe, bframe} = 
  NDSolveValue[{tangent'[t] == 
     Norm[γ'[t]]  {normal[t] . κ[t], 
        binormal[t] . κ[t]} . {normal[t], binormal[t]}, 
    normal'[t] == -Norm[γ'[t]]  tangent[t]*
      normal[t] . κ[t], 
    binormal'[t] == -Norm[γ'[t]]  tangent[t]*
      binormal[t] . κ[t], tangent[t0] == T0, normal[t0] == N0, 
    binormal[t0] == B0}, {normal, binormal}, {t, c1, c2}, 
   Method -> {"OrthogonalProjection", Dimensions -> {3, 3}}];
font = MeshPrimitives[
   BoundaryDiscretizeGraphics[Text[Style["*", 40]], _Text], 1];
cycles = 
  Append[#, First@#] & /@ 
   ConnectedComponents@Graph[Rule @@@ font[[;; , 1]]];
profile = BSplineFunction /@ cycles;
L = .3;
g = ParametricPlot3D[
  Table[γ[t] + 
    L*Indexed[profile, i][u] . {nframe[t], bframe[t]}, {i, 
    Length@profile}], {t, c1, c2}, {u, 0, 1}, Boxed -> False, 
  PlotPoints -> 150, MaxRecursion -> 2, PerformanceGoal -> "Speed", 
  PlotRange -> All, Axes -> False, ColorFunction -> "MintColors"]