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

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?

• For best results, export the spline coordinates and just use Blender. If you really want to continue in Mathematica, turn the curve into a Bezier spline and use Tube, and MaterialShading. Commented Jan 22 at 18:43

• 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"]
`