8
$\begingroup$

On Making a LocatorSphere:

Okay so I'm trying to realize a Locator3D-esque functionality for Mathematica. Something like a LocatorSphere, possibly done in a way that the LocatorVector can be locked to certain regions/quadrants to ease confusion for the user and prevent egregious errors from occurring.

This will ultimately not be used on a sphere as seen here, so some aspect of customization should be possible (as you see how I have begun to add my own axes) and it needs to output coordinates that can readily be accessed in order to operate other functions, to be used as a locator. For simplicity's sake, it should stay normalized in length. I have something that I think I have taken as far as my skill level can take it. Also, apologies on not having a gif, feel free to add this or a better picture in an edit.

By modifying this answer:
Forcing a locator button to remain on the surface of a sphere

I have been able to do the following, which I think is quite a bit towards this goal, but can be taken further and/or optimized and simplified.

DynamicModule[{pt}, Manipulate[
  EventHandler[
   Style[
    Graphics3D[{
      {Opacity[0.5],
       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]]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, Dynamic@pp[[1]]}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {1.5, 0., 0.}}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {0., 1.5, 0.}}]},

      {Thick, Arrowheads[Large, Appearance -> "Projected"], 
       Arrow[{{0., 0., 0.}, {0., 0., 1.5}}]}},

     Boxed -> False, PlotRange -> 1.6,

     Epilog -> 
      Inset[Style[
        "\[Phi]=" <> ToString[#[[2]]] <> ", \[Theta]=" <> 
           ToString[#[[3]]] &@ToSphericalCoordinates[pp[[1]]], 
        FontColor -> 
         Dynamic@If[CurrentValue["ShiftKey"], Black, Gray], 
        18], {Left, Top}, {Left, Top}], 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.}}]]],
  {{pp, Normalize /@ {{1., 1., 1.}}}, None},
  {nf, None},
  AutorunSequencing -> {2}]]

Which gives something like this:

LocatorSphereAttempt

But there are a few things I cannot make my brain figure out:

1. How to have a Locator click-and-drag-the-end-of-the-arrow type functionality?

When you use Locator instead of None in the last argument for pp in manipulate, it ends up creating several errors namely due to the fact that Locator uses a 2-D field to deliver its coordinates rather than the implemented 3-D one given by holding shift and moving the mouse around.

2. How to make the located coordinates usable in/able to be passed to other functions?

I genuinely cannot figure out how to access these dynamic variables. Though I can get the proper manipulation of them to occur within the Manipulate, it would be great to purposefully leak them to use in other functions, like how a Locator is designed to work.

3. How to lock the LocatorVector to a specific region/quadrant or set of values to prevent the user from making errors based on location choice?

I think this has something to do with the "Graphics3DBoxIntercepts" but I could not get anything meaningful to occur through my experimentation with it.

4. How to alter the view angle so that the region the vector starts in is visible to the user without manually rotating the Graphics3D?

This should be an easy one, I think...

5. How to improve this implementation further?

I know this can be immensely improved, and I hope others find this useful, even in its current, rough-and-tumbled format.

$\endgroup$
9
$\begingroup$

Here's something to get you started with a new design.

First we make the function that actually makes a DynamicModule. It supports having more than just a sphere as a background, but I haven't really played with that. It also supports the Dynamic vocabulary appropriately.

I included a "PointNormalizer" in case you want to pass in a Region as the background and use NearestFunction to compute the nearest point on the region.

I also added in support for automatic ViewPoint changes on "MouseUp".

The only annoying thing is that giving a dynamic value for PassEventsDown means standard rotations of the scene can be slow...

iVectorLocator // Clear
Options[iVectorLocator] =
  {
   "PointNormalizer" -> Normalize,
   "RotateView" -> True
   };
iVectorLocator[
  Dynamic[pt_, {fstart_, f : Except[OptionsPattern[]], fend_}, 
    dops : OptionsPattern[]] |
   Dynamic[pt_, {f : Except[OptionsPattern[]], fend_}, 
    dops : OptionsPattern[]] |
   Dynamic[pt_, f : Except[OptionsPattern[]], dops : OptionsPattern[]] |
   Dynamic[pt_, dops : OptionsPattern[]],
  arrowFunction_: Automatic,
  background_: Automatic,
  ops : OptionsPattern[{iVectorLocator, Graphics3D}]
  ] :=
 DynamicModule[
  {
   active,
   getMousePoint,
   getViewPoint,
   bg,
   ar,
   during,
   pre,
   post,
   vpt,
   rv = OptionValue["RotateView"]
   },
  bg =
   Replace[background, 
    Automatic :>
     {
      {
       Opacity[0.5],
       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]]
       },
      {
       GrayLevel[.5],
       Dashed,
       {Thick,
        Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {1.5, 0., 0.}}]
        }, {Thick, Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {0., 1.5, 0.}}]},
       {
        Thick,
        Arrowheads[Large, Appearance -> "Projected"], 
        Arrow[{{0., 0., 0.}, {0., 0., 1.5}}]
        }
       }
      }
    ];
  ar =
   Replace[
    arrowFunction,
    Automatic :>
     Function[
      Null,
      {
       Thick,
       Arrowheads[Large, Appearance -> "Projected"],
       Arrow[{{0., 0., 0.}, Dynamic[#, #2]}]
       },
      HoldFirst
      ]
    ];
  Replace[
   ar[pt, Flatten@{dops}],
   e : With[{aar = ar}, Except[_aar]] :> Set[ar, e]
   ];
  EventHandler[
   Graphics3D[
    {bg, ar},
    FilterRules[
     {
      ops,
      Boxed -> False,
      PlotRange -> 1.6,
      ImageSize -> {Automatic, 400},
      RotationAction -> "Clip",
      If[TrueQ@rv,
       ViewPoint -> Dynamic[vpt],
       Nothing
       ]
      },
     Options[Graphics3D]
     ]
    ],
   {
    "MouseDown" :>
     If[CurrentValue["ShiftKey"],
      pre[pt, getMousePoint[]];
      active = True;
      ],
    "MouseUp" :>
     If[active,
      post[pt, getMousePoint[]];
      If[rv, vpt = getViewPoint[]];
      active = False
      ],
    "MouseDragged" :>
     If[active,
      during[pt, getMousePoint[]]
      ],
    PassEventsDown -> FEPrivate`Not[FrontEnd`CurrentValue["ShiftKey"]]
    }
   ],
  Initialization :> {
    If[! ValueQ[pt], pt = Normalize[{1., 1., 1.}]],
    If[rv, vpt = getViewPoint[], vpt = Automatic],
    during = Replace[{f}, {} | {Automatic} -> {Set}][[1]],
    pre = Replace[{fstart}, {} | {Automatic} -> {during}][[1]],
    post = Replace[{fend}, {} | {Automatic} -> {during}][[1]],
    With[{norm = OptionValue["PointNormalizer"]},
     getMousePoint[] :=
      norm@First@
        MousePosition[
         "Graphics3DBoxIntercepts", {{-1., -1., -1.}, {1., 1., 1.}}]
     ],
    getViewPoint[] :=
     pt*2
    }
  ]

Now we'll turn that into a Formatted form of a different object. This is how most FE things are built.

Options[VectorLocator] =
  {
   Appearance -> Automatic
   };
Format[
  v :
   VectorLocator[
    d : (
      Dynamic[pt_, {fstart_, f : Except[OptionsPattern[]], fend_}, 
        dops : OptionsPattern[]] |
       Dynamic[pt_, {f : Except[OptionsPattern[]], fend_}, 
        dops : OptionsPattern[]] |
       Dynamic[pt_, f : Except[OptionsPattern[]], dops : OptionsPattern[]] |
       Dynamic[pt_, dops : OptionsPattern[]]
      ),
    background : Except[OptionsPattern[]] : Automatic,
    ops : OptionsPattern[{VectorLocator, Graphics3D, iVectorLocator}]
    ],
  StandardForm
  ] :=
 Interpretation[
  iVectorLocator[d, 
   OptionValue[{VectorLocator, Graphics3D, iVectorLocator}, {ops}, 
    Appearance], 
   background,
   FilterRules[
    {ops},
    Join[Options[iVectorLocator], Options[Graphics3D]]
    ]
   ],
  v
  ]

Now you can use it in the normal way like:

VectorLocator[Dynamic[vec], Background -> LightBlue]

enter image description here

or if you want it to spit out the end position:

VectorLocator[Dynamic[vec, {Automatic, Echo[#] &}], Background -> LightBlue]

or if you want a different shape as the background:

VectorLocator[Dynamic[pt], 
 GeometricTransformation[Sphere[], ScalingTransform[{1, .5, .5}]],
 Axes -> True,
 AxesOrigin -> {0, 0, 0}
 ]

enter image description here

And as you might guess from the fact that we pass a Dynamic as the first argument, if two of these things share the same variable and update to one will affect the other, which can be interesting to watch.

I think I actually hit the first four of your requests in doing this, even if by accident, too.

| improve this answer | |
$\endgroup$
  • $\begingroup$ Bravo! Stupendo! Bellissimo! This is a learning experience to say the least, I will leave this open for a good day or so before I lock in the check-a-doodle-doo, but I think this is a clearly nailed answer. One thing, when you put the "RotateView" to false, it throws an error before you interact with it, after this it is good to go. Probably some error on my part, but it is the only issue and a rather small insignificant one at-that. This is amazing! $\endgroup$ – CA Trevillian Jan 30 at 8:24
  • 1
    $\begingroup$ @CATrevillian I might have forgotten to put the updated code on there. Give it another go. $\endgroup$ – b3m2a1 Jan 30 at 8:31
  • $\begingroup$ Ah, funny funny, it only occurs when I do not delete the prior output, which makes sense. That would be the only way for Viewpoint Automatic is not a triple of numbers or a recognized symbolic form. to be outputted as an error, because the previously defined Dynamic is picking up the newly defined value of vpt before the whole construct is updated upon user interaction. Quite curious, but altogether, I think, user error on my part :D $\endgroup$ – CA Trevillian Jan 30 at 8:48
  • $\begingroup$ @CATrevillian not user error, I'd say. Just kinda surprising. $\endgroup$ – b3m2a1 Jan 30 at 8:53
  • 1
    $\begingroup$ @CATrevillian the Dynamic[#,#2] is wrapped up in a Function head to make it a pure function. The FE just is bad at highlighting. Its purpose is to capture the passed variable and dynamic options. You can certainly add a Dynamic[...] there, but you can also pass a different arrow generating function via the Appearance option. E.g. VectorLocator[..., Appearance->Function[Null, Point[Dynamic[#, #2]], HoldFirst]] $\endgroup$ – b3m2a1 Jan 30 at 17:28

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.