2
$\begingroup$

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?

$\endgroup$
  • 1
    $\begingroup$ Related: 5802 $\endgroup$ – Simon Woods May 24 '15 at 8:07
3
$\begingroup$

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.

enter image description here

    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]])]
$\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.