Forcing a locator button to remain on the surface of a sphere

Question

This question may or may not be possible and might be a hard one to answer. Suppose that I have a sphere centered at the point (1,2,-1) with radius 3. Is it possible to place a locator button on the sphere, then now matter how it is dragged with the mouse, it is forced to remain on the sphere?

Answer 1

It can be done but needs a custom implementation. To save everyone's time on searching and coding, here is a Demonstrations that does it:

Voronoi Diagram on a Sphere by a very good coder Maxim Rytin

Note it breaks in latest V10.1 and I have not had the time to dig through it yet. When I figure it out I'll update the post. In the mean time, to save the time, feel free, folks, take a look at this too. Code is small. Feel free to edit post.

    Manipulate[
 EventHandler[Style[Graphics3D[
    {Dynamic@If[! s,
       {Opacity[.75], Sphere[]},
       nf = Nearest[pp -> Automatic];
       First@
        ParametricPlot3D[{Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}, {v, 
          0, Pi}, {u, 0, 2 Pi},
         MaxRecursion -> ControlActive[1, Automatic], 
         PlotPoints -> ControlActive[Automatic, 50],
         MeshStyle -> None, Mesh -> {Range[3/2, Length@pp - 1/2]},
         MeshShading -> Hue /@ (Range@Length@pp/Length@pp),
         MeshFunctions -> {First@nf[{#, #2, #3}, 1] &}]],
     Dynamic@vd@pp,
     {Red, Sphere[Dynamic@pp, .05]}},
    Boxed -> False, PlotRange -> 1.1,
    Epilog -> Inset[Style["Shift+mouseover",
       FontColor -> Dynamic@If[CurrentValue["ShiftKey"], Black, Gray]],
      {Right, Bottom}, {Right, Bottom}],
    ImageSize -> {Automatic, 400}, RotationAction -> "Clip"],
   Deployed -> Dynamic@CurrentValue["ShiftKey"]],
  "MouseMoved" :>
   If[CurrentValue["ShiftKey"],
    (pp[[First@
          Ordering[Function[pt, (pt - #).(pt - #)] /@ pp, 
           1]]] = #) &@
     Normalize@
      First@MousePosition[
        "Graphics3DBoxIntercepts", {{-1., -1., -1.}, {1., 1., 
          1.}}]]],
 {{n, 4, "number of points"}, 4, 15, 1,
  Manipulator[Dynamic[n,
     If[(n = #) < Length@pp,
       pp = Take[pp, n],
       pp = 
        Join[pp, 
         Normalize /@ 
          RandomReal[
           NormalDistribution[], {n - Length@pp, 3}]]] &], #2,
    Appearance -> "Labeled"] &},
 {{s, False, "fill regions"}, {True, False}, Checkbox},
 {{pp, Normalize /@ RandomReal[NormalDistribution[], {4, 3}]}, None},
 {nf, None},
 AutorunSequencing -> {2},
 Initialization :>
  ((*Needs["TetGenLink`"];*)

   With[{$TetGenLibrary = 
      FileNameJoin[{$InstallationDirectory, "SystemFiles", "Links", 
        "TetGenLink",
        "LibraryResources", $SystemID, "tetgenWolfram." ~~ Which[
          StringMatchQ[$SystemID, "Windows" ~~ ___], "dll",
          StringMatchQ[$SystemID, "Mac" ~~ ___], "dylib",
          _, "so"]}]},
    instanceFun = 
     LibraryFunctionLoad[$TetGenLibrary, "newTetGenInstance", {}, 
      Integer];
    setPointsFun = 
     LibraryFunctionLoad[$TetGenLibrary, 
      "setPointList", {Integer, {Real, 2, "Shared"}}, Integer];
    tetrahedralizeFun = 
     LibraryFunctionLoad[$TetGenLibrary, "tetrahedralizeFun", 
      LinkObject, LinkObject];
    getPointsFun = 
     LibraryFunctionLoad[$TetGenLibrary, 
      "getPointList", {Integer}, {Real, _}];
    getFacesFun = 
     LibraryFunctionLoad[$TetGenLibrary, 
      "getFaces", {Integer}, {Integer, 2}];
    deleteFun = 
     LibraryFunctionLoad[$TetGenLibrary, 
      "deleteTetGenInstance", {Integer}, Integer]];
   ch[pts_] := Module[
     {inInst, outInst},
     {inInst, outInst} = instanceFun @@@ {{}, {}};
     setPointsFun[inInst, Developer`ToPackedArray@N@pts];
     tetrahedralizeFun["-E", inInst, outInst];
     (deleteFun /@ {inInst, outInst}; #) &@
      {getPointsFun@outInst, getFacesFun@outInst + 1}];

   vd[pts_ /; Length@pts > 3] := Module[
     {verts, polys, voronoiverts, segs},
     {verts, polys} =(*TetGenLink`TetGenConvexHull*)ch@pts;
     voronoiverts = 
      Normalize /@
       (Cross[verts[[#3]] - verts[[#]], 
           verts[[#2]] - verts[[#]]] &) @@@ polys;
     segs = If[Length[Intersection @@ polys[[{##}]]] < 2, {},
         ParametricPlot3D[

          Normalize[
            voronoiverts[[#]] t + voronoiverts[[#2]] (1 - t)] //

                 Evaluate, {t, 0, 1}, 
          PlotStyle -> AbsoluteThickness[2]]
         ] & @@@ Subsets[Range@Length@polys, {2}];
     First@Show[segs]])]