0
$\begingroup$

I want to plot geodesics on surfaces, where I can change the surface and its parameters.

Manipulate[{
    coord = {u, v};

    velocities = {D[u[t], t], D[v[t], t]};
    n = 2;
    Which[manifold == "Torus" ,
    surface[u_, v_] = {(R + r Cos[v]) Cos[u], (R + r Cos[v]) Sin[u], 
     r Sin[v]};
    metric[u_, 
     v_] = {{D[surface[u, v], u].D[surface[u, v], u], 
       D[surface[u, v], u].D[surface[u, v], v]}, {D[surface[u, v], 
         v].D[surface[u, v], u], 
       D[surface[u, v], v].D[surface[u, v], v]}} // FullSimplify;
   inversemetric[u_, v_] = Simplify[Inverse[metric[u, v]]];
   affine[u_, v_] = 
    Simplify[Table[(1/2)*Sum[(inversemetric[u, v][[i, s]])*
         (D[metric[u, v][[s, j]], coord[[k]] ] +
           D[metric[u, v][[s, k]], coord[[j]] ] - 
           D[metric[u, v][[j, k]], coord[[s]] ]), {s, 1, n}],
      {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
   geodesic[u_, v_] = 
    Simplify[
     Table[-Sum[
        affine[u[t], v[t]][[i, j, k]] velocities[[j]] velocities[[
          k]], {j, 1, n},
        {k, 1, n}], {i, 1, n}]];
   riemann[u_, v_] = Simplify[Table[
      D[affine[u, v][[i, j, l]], coord[[k]] ] - 
       D[affine[u, v][[i, j, k]], coord[[l]] ] +
       Sum[
        affine[u, v][[s, j, l]] affine[u, v][[i, k, s]] - 
         affine[u, v][[s, j, k]] affine[u, v][[i, l, s]],
        {s, 1, n}],
      {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
   ricci[u_, v_] = 
    Simplify[
     Table[Sum[riemann[u, v][[i, j, i, l]], {i, 1, n}], {j, 1, n}, {l,
        1, n}] ];
   scalar[u_, v_] = 
    Simplify[
     Sum[inversemetric[u, v][[i, j]] ricci[u, v][[i, j]], {i, 1, 
       n}, {j, 1, n}] ], manifold == "ellipsoid", 
   surface[u_, v_] = {a Cos[u] Sin[v], b Sin[u] Sin[v], c Cos[v]};
   metric[u_, 
     v_] = {{D[surface[u, v], u].D[surface[u, v], u], 
       D[surface[u, v], u].D[surface[u, v], v]}, {D[surface[u, v], 
         v].D[surface[u, v], u], 
       D[surface[u, v], v].D[surface[u, v], v]}} // FullSimplify;
   inversemetric[u_, v_] = Simplify[Inverse[metric[u, v]]];
   affine[u_, v_] = 
    Simplify[Table[(1/2)*Sum[(inversemetric[u, v][[i, s]])*
         (D[metric[u, v][[s, j]], coord[[k]] ] +
           D[metric[u, v][[s, k]], coord[[j]] ] - 
           D[metric[u, v][[j, k]], coord[[s]] ]), {s, 1, n}],
      {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
   geodesic[u_, v_] = 
    Simplify[
     Table[-Sum[
        affine[u[t], v[t]][[i, j, k]] velocities[[j]] velocities[[
          k]], {j, 1, n},
        {k, 1, n}], {i, 1, n}]];
   riemann[u_, v_] = Simplify[Table[
      D[affine[u, v][[i, j, l]], coord[[k]] ] - 
       D[affine[u, v][[i, j, k]], coord[[l]] ] +
       Sum[
        affine[u, v][[s, j, l]] affine[u, v][[i, k, s]] - 
         affine[u, v][[s, j, k]] affine[u, v][[i, l, s]],
        {s, 1, n}],
      {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
   ricci[u_, v_] = 
    Simplify[
     Table[Sum[riemann[u, v][[i, j, i, l]], {i, 1, n}], {j, 1, n}, {l,
        1, n}] ];
   scalar[u_, v_] = 
    Simplify[
     Sum[inversemetric[u, v][[i, j]] ricci[u, v][[i, j]], {i, 1, 
       n}, {j, 1, n}] ]];
  
  tend = 20; nn = 20;
  ics1 = {\[Theta], \[Phi], Sin[Cos[Pi \[Alpha]/nn]], 
    Cos[Cos[Pi \[Alpha]/nn]]};
  ics2 = {\[Theta] + \[Delta]\[Theta], \[Phi] + \[Delta]\[Phi], 
    Sin[Cos[Pi \[Alpha]/nn]], Cos[Cos[Pi \[Alpha]/nn]]};
  s = (metric[\[CapitalPhi][t], \[CapitalTheta][t]][[1, 
        1]] Derivative[1][\[CapitalPhi]][t]^2 + 
      2 metric[\[CapitalPhi][t], \[CapitalTheta][t]][[1, 
        2]] Derivative[1][\[CapitalPhi]][t] Derivative[
        1][\[CapitalTheta]][t] + 
      metric[\[CapitalPhi][t], \[CapitalTheta][t]][[2, 2]] Derivative[
        1][\[CapitalTheta]][t]^2) /. {\[CapitalTheta][t] -> ics1[[1]],
      Derivative[1][\[CapitalTheta]][t] -> ics1[[3]], 
     Derivative[1][\[CapitalPhi]][t] -> ics1[[4]]};
  \[Delta]s = (metric[\[CapitalPhi][t], \[CapitalTheta][t]][[1, 
        1]] Derivative[1][\[CapitalPhi]][t]^2 + 
      2 metric[\[CapitalPhi][t], \[CapitalTheta][t]][[1, 
        2]] Derivative[1][\[CapitalPhi]][t] Derivative[
        1][\[CapitalTheta]][t] + 
      metric[\[CapitalPhi][t], \[CapitalTheta][t]][[2, 2]] Derivative[
        1][\[CapitalTheta]][t]^2) /. {\[CapitalTheta][t] -> ics2[[1]],
      Derivative[1][\[CapitalTheta]][t] -> ics2[[3]], 
     Derivative[1][\[CapitalPhi]][t] -> ics2[[4]]};
  ics = {ics1[[1]], ics1[[2]], ics1[[3]]/Sqrt[s], ics1[[4]]/Sqrt[s]};
  \[Delta]ics = {ics2[[1]], ics2[[2]], ics2[[3]]/Sqrt[\[Delta]s], 
    ics2[[4]]/Sqrt[\[Delta]s]};
  
  sol = NDSolve[{-geodesic[\[CapitalPhi], \[CapitalTheta]][[
         2]] + (\[CapitalTheta]^\[Prime]\[Prime])[t] == 
      0, -geodesic[\[CapitalPhi], \[CapitalTheta]][[
         1]] + (\[CapitalPhi]^\[Prime]\[Prime])[t] == 
      0, \[Xi]''[t] + 
       0.5 scalar[\[CapitalPhi][t], \[CapitalTheta][t]] \[Xi][t] == 
      0, \[Xi][0] == 0, \[Xi]'[0] == 1, \[CapitalTheta][0] == 
      ics[[1]], \[CapitalPhi][0] == ics[[2]], \[CapitalTheta]'[0] == 
      ics[[3]], \[CapitalPhi]'[0] == 
      ics[[4]]}, {\[CapitalTheta], \[CapitalPhi], \[Xi]}, {t, 0, 
     tend}, Method -> {"EventLocator", "Event" -> \[Xi][t], 
      "Direction" -> -1}];
  \[Delta]sol = 
   NDSolve[{-geodesic[\[CapitalPhi], \[CapitalTheta]][[
         2]] + (\[CapitalTheta]^\[Prime]\[Prime])[t] == 
      0, -geodesic[\[CapitalPhi], \[CapitalTheta]][[
         1]] + (\[CapitalPhi]^\[Prime]\[Prime])[t] == 
      0, \[Xi]''[t] + 
       0.5 scalar[\[CapitalPhi][t], \[CapitalTheta][t]] \[Xi][t] == 
      0, \[Xi][0] == 0, \[Xi]'[0] == 
      1, \[CapitalTheta][0] == \[Delta]ics[[1]], \[CapitalPhi][
       0] == \[Delta]ics[[2]], \[CapitalTheta]'[0] == \[Delta]ics[[
       3]], \[CapitalPhi]'[0] == \[Delta]ics[[
       4]]}, {\[CapitalTheta], \[CapitalPhi], \[Xi]}, {t, 0, tend}, 
    Method -> {"EventLocator", "Event" -> \[Xi][t], 
      "Direction" -> -1}];
  
  newt = sol[[1, 1, 2, 1, 1, 2]];
  \[Delta]newt = \[Delta]sol[[1, 1, 2, 1, 1, 2]];
  
  plt1 = ParametricPlot3D[
    surface[\[CapitalPhi][t], \[CapitalTheta][t]] /. sol, {t, 0, 
     Min[rad, newt]}, PlotStyle -> Thickness[0.0025], 
    PerformanceGoal -> Quality];
  \[Delta]plt1 = 
   ParametricPlot3D[
    surface[\[CapitalPhi][t], \[CapitalTheta][t]] /. \[Delta]sol, {t, 
     0, Min[rad, newt]}, PlotStyle -> Thickness[0.0025], 
    PerformanceGoal -> Quality];
  
  newth = \[CapitalTheta][newt] /. sol;
  newph = \[CapitalPhi][newt] /. sol;
  \[Delta]newth = \[CapitalTheta][\[Delta]newt] /. \[Delta]sol;
  \[Delta]newph = \[CapitalPhi][\[Delta]newt] /. \[Delta]sol;
  ;
  GKinitial = D[0.5 scalar[x, t], t] /. {t -> \[Theta]}[[1]];
  Kinitial = 0.5 scalar[x, t] /. {t -> \[Theta]}[[1]];
  LKinitial = GKinitial/Kinitial;
  GKfinal = D[0.5 scalar[x, t], t] /. {t -> newth}[[1]];
  Kfinal = 0.5 scalar[x, t] /. {t -> newth}[[1]];
  LKfinal = GKfinal/Kfinal;
  \[Delta]sinitial = 
   Sqrt[metric[\[Phi], \[Theta]]].{\[Delta]\[Phi], \[Delta]\[Theta]};
  \[Delta]sfinal = 
   Sqrt[metric[newph[[1]], 
      newth[[1]]]].{newph[[1]] - \[Delta]newph[[1]], 
     newth[[1]] - \[Delta]newth[[1]]};
  
  Show[Graphics3D[{Blue, Sphere[surface[\[Phi], \[Theta]], 0.025], 
     Red, Sphere[
      surface[\[Phi] + \[Delta]\[Phi], \[Theta] + \[Delta]\[Theta]], 
      0.025], Blue, Sphere[surface[newph[[1]], newth[[1]]], 0.025], 
     Red, Sphere[surface[\[Delta]newph[[1]], \[Delta]newth[[1]]], 
      0.025]}], plt1, \[Delta]plt1, 
   ParametricPlot3D[surface[th, ph], {th, 0, 2 Pi}, {ph, 0, 2 Pi}, 
    PlotStyle -> Opacity[1], PerformanceGoal -> "Quality", 
    Mesh -> None], Axes -> False, Boxed -> False, ImageSize -> Large, 
   ViewAngle -> 15 Degree
   ], "u\!\(\*SubscriptBox[\(\[Del]\), \(u\)]\)lnK\!\(\*SubscriptBox[\
\(|\), \(p\)]\)=" <> 
   ToString[{\[Delta]\[Phi], \[Delta]\[Theta]}.{0, LKinitial}], 
  "w\!\(\*SubscriptBox[\(\[Del]\), \
\(w\)]\)lnK\!\(\*SubscriptBox[\(|\), \(q\)]\)=" <> 
   ToString[{newph[[1]] - \[Delta]newph[[1]], 
      newth[[1]] - \[Delta]newth[[1]]} .{0, LKfinal[[1]]}]}
 , {{R, 2, "R"}, 1, 3, Appearance -> "Labeled"}, {{r, 1, "r"}, 0.1, 3,
   Appearance -> "Labeled"}, {{a, 1, "a"}, 1, 3, 
  Appearance -> "Labeled"}, {{b, 1, "b"}, 1, 3, 
  Appearance -> "Labeled"}, {{c, 1.5, "c"}, 1, 3, 
  Appearance -> "Labeled"},
 {{\[Theta], 0.4, 
   "cos \!\(\*SubscriptBox[\(\[Theta]\), \(0\)]\)"}, -1, 1, 
  Appearance -> "Labeled"}, {{\[Delta]\[Theta], 0.001, 
   " \[Delta] cos \[Theta]"}, -0.005, 0.005, 
  Appearance -> "Labeled"}, {{\[Alpha], 1, " initial angle"}, 1, 20, 
  Appearance -> "Labeled"},
 {{\[Phi], -0.5, "\!\(\*SubscriptBox[\(\[Phi]\), \(0\)]\)"}, -Pi, Pi, 
  Appearance -> "Labeled"}, {{\[Delta]\[Phi], 0.001, 
   "\[Delta]\[Phi]"}, -0.005, 0.005, 
  Appearance -> "Labeled"}, {manifold, {"Torus", "ellipsoid"}},
 {{rad, 10, "radius"}, 0.001, 20, Appearance -> "Labeled"}]

I'm choosing a surface, torus or ellipsoid, calculating its geodesic equations and curvature and then solve an ODE. Via Manipulate I control the parameters of the surface, i.e. the radius of the torus. I want to do the geodesic calculations

metric[u_, 
   v_] = {{D[surface[u, v], u].D[surface[u, v], u], 
     D[surface[u, v], u].D[surface[u, v], v]}, {D[surface[u, v], v].D[
       surface[u, v], u], D[surface[u, v], v].D[surface[u, v], v]}} //
    FullSimplify;
inversemetric[u_, v_] = Simplify[Inverse[metric[u, v]]];
affine[u_, v_] = 
  Simplify[Table[(1/2)*Sum[(inversemetric[u, v][[i, s]])*
       (D[metric[u, v][[s, j]], coord[[k]] ] +
         D[metric[u, v][[s, k]], coord[[j]] ] - 
         D[metric[u, v][[j, k]], coord[[s]] ]), {s, 1, n}],
    {i, 1, n}, {j, 1, n}, {k, 1, n}] ];
geodesic[u_, v_] = 
  Simplify[Table[-Sum[
      affine[u[t], v[t]][[i, j, k]] velocities[[j]] velocities[[
        k]], {j, 1, n},
      {k, 1, n}], {i, 1, n}]];
riemann[u_, v_] = Simplify[Table[
    D[affine[u, v][[i, j, l]], coord[[k]] ] - 
     D[affine[u, v][[i, j, k]], coord[[l]] ] +
     Sum[affine[u, v][[s, j, l]] affine[u, v][[i, k, s]] - 
       affine[u, v][[s, j, k]] affine[u, v][[i, l, s]],
      {s, 1, n}],
    {i, 1, n}, {j, 1, n}, {k, 1, n}, {l, 1, n}] ];
ricci[u_, v_] = 
  Simplify[Table[
    Sum[riemann[u, v][[i, j, i, l]], {i, 1, n}], {j, 1, n}, {l, 1, 
     n}] ];
scalar[u_, v_] = 
 Simplify[Sum[
   inversemetric[u, v][[i, j]] ricci[u, v][[i, j]], {i, 1, n}, {j, 1, n}] ]

Outside the manipulate, but Im not sure how because the parameter Im changing inside Manipulate change the surface. The calculation of the metric is general for any surface, but depends on its parameters.

$\endgroup$

1 Answer 1

2
$\begingroup$

It is hard to figure out what is the question since you have so much code and you only said

but Im not sure how because the parameter Im changing inside Manipulate change the surface.

Which does not say exactly what is the problem.

It would have been much better to also make a MWE.

But I am guessing you have problem controlling a variable in an expression outside Manipulate from inside Manipulate. If this is not the problem, will delete this.

You can not do the following

ClearAll[a, x]
expr = Sin[a*x]
Manipulate[expr,
 {{a, 1, "a"}, 0.1, 10, .1, Appearance -> "Labeled"},
 TrackedSymbols :> {a}
 ]

Since a do not appear inside Manipulate.

enter image description here

One way around this is to replacement. Like this

ClearAll[a, x]
expr = Sin[a*x]
Manipulate[expr /. a -> a0,
 {{a0, 1, "a"}, 0.1, 10, .1, Appearance -> "Labeled"},
 TrackedSymbols :> {a0}
 ]

And now you are able to change a inside the outside expression from inside.

enter image description here

There is another way to solve this problem. Which is to add LocalizeVariables->False

ClearAll[a, x]
expr = Sin[a*x];
Manipulate[expr,
 {{a, 1, "a"}, 0.1, 10, .1, Appearance -> "Labeled"},
 LocalizeVariables -> False,
 TrackedSymbols :> {a}
 ]

enter image description here

I prefer the replacement method, as it is safer.

If this is not the issue you are having, then may be more explanation is needed. Again, making a MWE is always best. Your code is way too large to know what is the problem you are having.

$\endgroup$

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.