1
$\begingroup$

I am trying to plot the solutions to the Kepler problem. I am using Manipulate. It plots the orbits, the equipotential lines and the position of the planet. When I move the time variable, only the position of the planet changes, but mathematica seems to recalculate the equipotential lines and the orbits. What should I change?

\[Epsilon] = 
  2^10 $MachineEpsilon; (*Added \[Epsilon] to the denominator to \
avoid division by 0*) 
vars = {q[t], p[t]}; 
range = 1.5;  (*Range of the plots*)

pVector[{q_, p_}] := 
 Arrow@{q, 
   q + .5 p} (*The arrow showing the momentum should be scaled by a \
0.5 factor*)

keplerEqs[q0_, 
   p0_] = {{Derivative[1][q][t] == p[t], 
    Derivative[1][p][t] == -(q[t]/(Norm[q[t]]^3 + \[Epsilon]))}, {q[
      0] == q0, p[0] == p0}};
V[q_] := -1/(Norm@q + \[Epsilon]) (*Kepler's potential*)

keplerSol[q0_, p0_, tmax_] := 
  keplerSol[q0, p0] = 
   First@NDSolve[keplerEqs[q0, p0], vars, {t, -tmax, tmax}];

Manipulate[
 Q = Evaluate[q[t] /. keplerSol[q0, p0, tmax]];
 P = Evaluate[p[t] /. keplerSol[q0, p0, tmax]];

 show = {showPotential, showOrbit, showP0, showQ, 
   showP}; (*Things that should be shown in the graph*)

 plots = {potentialPlot, orbitPlot, P0Plot, QPlot, PPlot};

 potentialPlot = 
  ContourPlot[V[{x, y}], {x, -range, range}, {y, -range, range}, 
   PlotLegends -> Automatic, ContourShading -> None];
 orbitPlot = ParametricPlot[Evaluate@Q,
   {t, -tmax, tmax}
   ];
 P0Plot = Graphics@pVector[{q0, p0}];
 QPlot = Graphics@{PointSize[0.05], Point[Evaluate@(Q /. t -> T)]};
 PPlot = Graphics@pVector[{Q, P} /. t -> T];

 Show[Pick[plots, show], PlotRange -> range, AxesLabel -> {"x", "y"}, 
  Axes -> True],

 (*Controls*)
 {{q0, {0.1, 1}}, Locator},
 {{q0, {0.1, 1}, "r0"}},
 {{p0, {1, .1}, "p0"}, {-1, -1}, {1, 1}},
 {{p0, {1, .1}, ""}}, Delimiter,
 {{T, 0, "t"}, -tmax, tmax, Appearance -> "Labeled"},
 {{tmax, 10, "tmax"}, 1, 20, Appearance -> "Labeled"},
 {{showOrbit, True, "Orbit"}, Checkbox, ControlPlacement -> Right},
 {{showPotential, False, "Potential"}, Checkbox, 
  ControlPlacement -> Right},
 {{showP0, True, "p0"}, Checkbox, ControlPlacement -> Right},
 {{showQ, False, "q(t)"}, Checkbox, ControlPlacement -> Right},
 {{showP, False, "p(t)"}, Checkbox, ControlPlacement -> Right}
 ]

UPDATE: I CHANGED THE CODE TO MAKE IT MORE READABLE, HOWEVER, THE SPACING IS NOT CONSERVED WHEN YOU COPY IT. THE ORIGINAL FILE IS HERE

$\endgroup$
  • 1
    $\begingroup$ if you make your code readable, may be you'll get better help. I can't even read the code. This is how it looks on my notebook !Mathematica graphics may be it will help if you start by removing all the subscript boxes stuff. $\endgroup$ – Nasser Nov 16 '14 at 5:04
  • $\begingroup$ Sorry, I did this very quickly. I'll rewrite it and update the question. $\endgroup$ – mlainz Nov 16 '14 at 12:58
4
$\begingroup$

I'm no Manipulate master, but from previous nasty experiences, I have a few tips:

Read the related tutorials, not only the direct documentation. They explain a great deal of the internal "mechanics", and have some examples that make for some great A-ha moments. - https://reference.wolfram.com/language/tutorial/IntroductionToDynamic.html - https://reference.wolfram.com/language/tutorial/AdvancedDynamicFunctionality.html - https://reference.wolfram.com/language/tutorial/IntroductionToManipulate.html

Regarding your code, you should aim to "produce dynamic content", not "produce content dynamically". In other words, you should use Dynamic surgically. Compare these:

Dynamic[Point[{x,y}]] (* Dynamically creates a new point for each new {x,y} coordinates *)

Point[Dynamic[{x,y}]] (* Creates a single point with coordinates {x,y} that dynamically change *)

The second Point uses less resources than the first, and is what you should aim for.

With that in mind, take a look at your code: a single Dynamic (that is created by Manipulate, as explained in the docs) wraps all your code and recalculates everything at every parameter change. If you help Manipulate by giving hints, through nested Dynamics, of what changes when, and also dived things hierarchically, you can achieve better performance

This changes whenever q0, p0 or tmax, changes.

Q = Evaluate[q[t] /. keplerSol[q0, p0, tmax]];
P = Evaluate[p[t] /. keplerSol[q0, p0, tmax]];
plotA = {ContourPlot[
    V[{x, y}], {x, -range, range}, {y, -range, range}, 
    PlotLegends -> Automatic, PlotTheme -> "Scientific", 
    ContourShading -> None, PerformanceGoal -> "Quality"], 
   ParametricPlot[Evaluate@Q, {t, -tmax, tmax}], 
   Graphics@pVector[{q0, p0}]};

But this only changes when T changes:

 plotB = {Graphics@{PointSize[0.05], 
          Point[Evaluate@(Q /. t -> T)]}, 
          Graphics@pVector[{Q, P} /. t -> T]};

And this, only when the showXXX parameters change:

 Show[Pick[ plotA ~Join~ plotB, {showPotential, showOrbit, showP0, showQ, 
      showP}], PlotRange -> 1.5, AxesLabel -> {"x", "y"}, Axes -> True]

Combining it all and adding some Dynamics on the smallest parts I could manage, the core of your Manipulate becomes

Q = Evaluate[q[t] /. keplerSol[q0, p0, tmax]];
P = Evaluate[p[t] /. keplerSol[q0, p0, tmax]];
plotA = {ContourPlot[
   V[{x, y}], {x, -range, range}, {y, -range, range}, 
   PlotLegends -> Automatic, PlotTheme -> "Scientific", 
   ContourShading -> None, PerformanceGoal -> "Quality"], 
  ParametricPlot[Evaluate@Q, {t, -tmax, tmax}, PlotPoints -> 100, 
   MaxRecursion -> 5], Graphics@pVector[{q0, p0}]};
plotB = {Graphics@{PointSize[0.05], 
    Dynamic@Point[Evaluate@(Q /. t -> T)]}, 
  Graphics@Dynamic@pVector[{Q, P} /. t -> T]};
Dynamic[
 Show[Pick[
   plotA~Join~plotB, {showPotential, showOrbit, showP0, showQ, 
    showP}], PlotRange -> 1.5, AxesLabel -> {"x", "y"}, Axes -> True]
 , TrackedSymbols :> {showPotential, showOrbit, showP0, showQ, showP}
 ]

Here's a comparison, with you version on the right:

Manipulate comparison

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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