1
$\begingroup$

I need to create the following: given two points on the surface of a unit sphere and a third one (that can be varied through Manipulate), find the point on the sphere that minimises the sum of the arc distances and then visualise the result. My attempt is based on the following code:

Arc3D[{a_, b_, m_}, n_: 60, prim_: Line] := 
  Module[{α, lab, axis, aarc, tm, alpha}, 
   lab = m + Norm[a - m]*Normalize[b - m];
   axis = (a - m)\[Cross](b - m);
   aarc = (VectorAngle[a - m, b - m]);
   tm = RotationMatrix[alpha, axis];
   prim @ Table[m + tm.(a - m), {alpha, 0, aarc, aarc/n}]];

or = {0, 0, 0};
u1 = 0;
f1 = 0;
u2 = Pi/3;
f2 = 0;
q = {Sin[u1] Cos[f1], Sin[u1] Sin[f1], Cos[u1]};
w = {Sin[u2] Cos[f2], Sin[u2] Sin[f2], Cos[u2]};
e := {Sin[u3] Cos[f3], Sin[u3] Sin[f3], Cos[u3]};
min := 
  NMinimize[
    {ArcCos[Cos[u1] Cos[ux] + Sin[u1] Sin[ux] Cos[f1 - fx]] + 
     ArcCos[Cos[u2] Cos[ux] + Sin[u2] Sin[ux] Cos[f2 - fx]] + 
     ArcCos[Cos[u3] Cos[ux] + Sin[u3] Sin[ux] Cos[f3 - fx]], 
     ux >= 0, ux <= Pi, fx >= 0, fx < 2 Pi}, {ux, fx}];
Ux := min[[2, 1, 2]];
Fx := min[[2, 2, 2]];
S := {Sin[Ux] Cos[Fx], Sin[Ux] Sin[Fx], Cos[Ux]};

followed by

Manipulate[
  Show[
    Graphics3D[
      {{Opacity[0.3], Sphere[{0, 0, 0}]}, 
       {Blue, Arc3D[{q, w, or}, 20]}, 
       {Blue, Arc3D[{w, e, or}, 20]}, 
       {Blue, Arc3D[{e, q, or}, 20]}, 
       {Green, Arc3D[{e, S, or}, 20]}, 
       {Green, Arc3D[{q, S, or}, 20]}, 
       {Green, Arc3D[{w, S, or}, 20]}, 
       Arrow[{{0, 0, 0}, q}],
       Arrow[{{0, 0, 0}, w}], 
       Arrow[{{0, 0, 0}, e}], 
       {Red, Arrow[{{0, 0, 0}, S}]}}], 
    Boxed -> False], 
  {{u3, Pi/2}, 0, Pi}, 
  {{f3, Pi/2}, 0, 2 Pi}]

which however returns a ton of errors. The code works if I remove the Manipulate command and I specify the coordinates for the third points, i.e. $e$, by giving explicit values to the angles $ux$ and $fx$. Thus, although the code is in principle working, it is the ``dynamic" part (user can change the $e$ point through manipulate) that fails.

Regarding the code, command Arc3D draws arcs between two points given their coordinates (ignore this part of the code as it is definitely working), min is the result of the numerical minimisation of the sum of the arc distances that are assigned to Ux and Fx and S are the cartesian coordinates of this ``minimal arc sum'' point.

All points are uniquely specified by the two angles $u,f$ but cartesian coordinates are also needed for drawing the arcs.

Can anyone find the error in my code and help me correct it?

An example of a working code ($e$ point specified in advance and no Manipulate command) returns the following graphic: enter image description here

which is exactly what I want to do but with the addition of being able to dynamically change one of the points.

$\endgroup$
2
  • 1
    $\begingroup$ The control variables u3 and f3 in your Manipulate expression are local to that expression and are, therefore, not the same as the global free variables u3 and f3 appearing outside the Manipulate expression. That is the first thing you should fix. $\endgroup$
    – m_goldberg
    Aug 8 '16 at 11:47
  • $\begingroup$ OK, thnx. I will try to correct this. $\endgroup$
    – AG1123
    Aug 8 '16 at 11:59
2
$\begingroup$

As a general comment I'd say that it is always best to avoid having so many global variables around, and even more avoid having implicit dependence on some other variable, like you have for your functions q, w, e ecc.

In fact, I modified your code localizing all the variables, and doing nothing more than that, and it turned out to work perfectly:

Arc3D[{a_, b_, m_}, n_: 60, prim_: Line] := 
  Module[{lab, axis, aarc, tm, alpha},
   lab = m + Norm[a - m]*Normalize[b - m];
   axis = (a - m)\[Cross](b - m);
   aarc = (VectorAngle[a - m, b - m]);
   tm = RotationMatrix[alpha, axis];
   prim@Table[m + tm.(a - m), {alpha, 0, aarc, aarc/n}]
   ];

q[u1_, f1_] := {Sin[u1] Cos[f1], Sin[u1] Sin[f1], Cos[u1]};
w[u2_, f2_] := {Sin[u2] Cos[f2], Sin[u2] Sin[f2], Cos[u2]};
e[u3_, f3_] := {Sin[u3] Cos[f3], Sin[u3] Sin[f3], Cos[u3]};
min[u1_, f1_, u2_, f2_, u3_, f3_] := NMinimize[
   {
    ArcCos[Cos[u1] Cos[ux] + Sin[u1] Sin[ux] Cos[f1 - fx]] +
     ArcCos[Cos[u2] Cos[ux] + Sin[u2] Sin[ux] Cos[f2 - fx]] +
     ArcCos[Cos[u3] Cos[ux] + Sin[u3] Sin[ux] Cos[f3 - fx]],
    ux >= 0, ux <= Pi, fx >= 0, fx < 2 Pi
    },
   {ux, fx}
   ];
Ux[u1_, f1_, u2_, f2_, u3_, f3_] := 
  min[u1, f1, u2, f2, u3, f3][[2, 1, 2]];
Fx[u1_, f1_, u2_, f2_, u3_, f3_] := 
  min[u1, f1, u2, f2, u3, f3][[2, 2, 2]];
S[u1_, f1_, u2_, f2_, u3_, f3_] := With[{
    ux = Ux[u1, f1, u2, f2, u3, f3],
    fx = Fx[u1, f1, u2, f2, u3, f3]
    },
   {Sin[ux] Cos[fx], Sin[ux] Sin[fx], Cos[ux]}
   ];

With[
 {u1 = 0, u2 = Pi/3, f1 = 0, f2 = 0, or = {0, 0, 0}},
 Manipulate[
  With[
   {q = q[u1, f1], w = w[u2, f2]},
   Module[{localS},
    localS[u3_, f3_] := S[u1, f1, u2, f2, u3, f3];
    Show[
     Graphics3D[{
       {Opacity[0.3], Sphere[{0, 0, 0}]},
       {Blue, Arc3D[{q, w, or}, 20]},
       {Blue, Arc3D[{w, e[u3, f3], or}, 20]},
       {Blue, Arc3D[{e[u3, f3], q, or}, 20]},
       {Green, Arc3D[{e[u3, f3], localS[u3, f3], or}, 20]},
       {Green, Arc3D[{q, localS[u3, f3], or}, 20]},
       {Green, Arc3D[{w, localS[u3, f3], or}, 20]},
       Arrow[{{0, 0, 0}, q}], Arrow[{{0, 0, 0}, w}], 
       Arrow[{{0, 0, 0}, e[u3, f3]}],

       {Red, Arrow[{{0, 0, 0}, localS[u3, f3]}]}
       }
      ],
     Boxed -> False
     ]
    ]
   ],
  {{u3, Pi/2}, 0, Pi}, {{f3, Pi/2}, 0, 2 Pi}
  ]
 ]

which produces the expected (I hope?) result: enter image description here

$\endgroup$
7
  • $\begingroup$ This still gives me a ft of errors. $\endgroup$
    – Feyre
    Aug 8 '16 at 11:55
  • $\begingroup$ Same for me. I first run the definitions in one cell and then the `With[...]' command but I get an error and the definitions are lost, as if the kernel quit and restarted. $\endgroup$
    – AG1123
    Aug 8 '16 at 11:58
  • $\begingroup$ I have 10.4.1.0 running on a Mac. I restarted Mathematica and run your code again but still did not work. $\endgroup$
    – AG1123
    Aug 8 '16 at 12:01
  • $\begingroup$ nevermind, I figured why. I didn't notice that min also used the values of u1, f1, u2, f2. I'll fix that and it will probably start working again $\endgroup$
    – glS
    Aug 8 '16 at 12:02
  • 1
    $\begingroup$ @AG1123 yup, see the updated code. It is admittedly a little longer due to the use of the With and Module to properly localise all the variables, and the specification of all the input variables to the functions, but it is a safer way to write code (and it is also much easier to find bugs) $\endgroup$
    – glS
    Aug 8 '16 at 12:12

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.