3
$\begingroup$

I am trying to redraw this illustration for the Poincaré section using Mathematica:

poincare illustration

For which I used this code as a start:

fullData = 
  Table[With[{\[Theta] = 2 \[Pi] u, \[CurlyPhi] = 
       2 \[Pi] v}, {(2 + Cos[\[CurlyPhi]]) Cos[\[Theta]], 
      Sin[\[CurlyPhi]], (2 + Cos[\[CurlyPhi]]) Sin[\[Theta]]}], {u, 0,
      1, 0.001}, {v, 0, 1, 0.003}] // Flatten[#, 1] &;
tol = 0.02;
secData = Select[fullData, Abs[#[[2]]] < tol &];
fullPlot = Graphics3D[{Blue, PointSize[Small], Point[fullData]}];

sectionPlot = Graphics3D[{Green, PointSize[Small], Point[secData]}];

planePlot = 
  Graphics3D[{Yellow, Opacity[0.4], 
    Polygon[{{-3, 0, -3}, {3, 0, -3}, {3, 0, 3}, {-3, 0, 3}}]}];

Show[fullPlot, sectionPlot, planePlot, Axes -> True, 
 AxesLabel -> {Style["x(\[Tau])", 14], Style["x'(\[Tau])", 14], 
   Style["x(\[Tau]-\[Tau]₀)", 14]}, BoxRatios -> {1, 1, 1}, 
 Lighting -> "Neutral", ImageSize -> Large]

Is there a better way by which I can draw a similar image, or any improvement I can make on this starting code to get a close image like the above figure?

Improve this question
$\endgroup$
1
  • $\begingroup$ If you can formulate your process as a differential equation, then you can use NDSolve and its WhenEvent features to detect crossings of the section plane. Simple example: NDSolve[{y[0] == 0, y'[0] == 1, y''[t] == -y[t], WhenEvent[y[t] == 0, Sow[t]]}, y[t], {t, 0, 10}] // Reap $\endgroup$ Commented Jun 23, 2025 at 19:44

1 Answer 1

Reset to default
2
$\begingroup$

You may want to use ParametricPlot3D to highlight the envelope of the cross section (dropping the axes labels here for easier code):

expr = {a  (Cos[t] + b) * Cos[phi], a  (Cos[t] + b) * Sin[phi], 
   0.3 a  Sin[t] + (a  (Cos[t] + b) * Sin[phi])*0.3};
params = {a -> .1, b -> 3, c -> 8 Pi, z -> .2};

fullData = 
  Table[Evaluate[expr /. phi -> c  t /. params], {t, 0, 40 Pi, 
    2 Pi/2000}];

Show[
 ParametricPlot3D[
  Evaluate[expr /. params], {t, 0, 2 \[Pi]}, {phi, 0, 2 \[Pi]}, 
  RegionFunction -> 
   Function[{x, y, z, u, v}, 0 < -y < 0.02 && x > 0], 
  PlotStyle -> Green, Mesh -> None, PlotTheme -> "Detailed", 
  PlotLegends -> None,
  PlotRange -> 
   Evaluate[{{-2  a  b, 2  a  b}, {-2  a  b, 2  a  b}, {-z, z}} /. 
     params]],
 Graphics3D[{Blue, PointSize[.001], Point@fullData, Yellow, 
   Opacity[.95], 
   Polygon[{{0, 0, -z}, {b*a*2, 0, -z}, {b*a*2, 0, z}, {0, 0, z}} /. 
     params]}]
 ]

Poincare Crosssection

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.