18
$\begingroup$

Here is a pared down example of some 3D data that I want to make dynamic and add locators to each set of points. Is that possible?

dimension1 = {{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0},
              {1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3},
              {4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4},
              {5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5},
              {6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6},
              {7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7},
              {8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8},
              {9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9},
              {10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10}};

dimension2 = {{2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2},
              {2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2}};

dimension3 = {{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
              {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10}};

firstDimension = ListPlot3D[dimension1, BoxRatios -> {1, 1, 1}, 
  PlotStyle -> {Cyan, Opacity[0.2]}, Background -> White];

secondDimension = ListPlot3D[dimension2, BoxRatios -> {1, 1, 1}, 
  PlotStyle -> {Magenta, Opacity[0.2]}, Background -> White];

thirdDimension = ListPlot3D[dimension3, BoxRatios -> {1, 1, 1}, 
  PlotStyle -> {Yellow, Opacity[0.2]}, Background -> White];

Show[firstDimension, secondDimension, thirdDimension]

Mathematica graphics

The locators should move the points on the grid, and affect the other surrounding points depending on a variable.

Improve this question
$\endgroup$
9
  • 4
    $\begingroup$ What is the purpose of the locators? What should happen when you move them? $\endgroup$
    – DavidC
    May 19, 2012 at 19:50
  • 1
    $\begingroup$ Some pieces/ideas in Kelly Lowder's BlockBuilder game in Wolfram Demonstrations should be useful to build a custom "Locator3D". $\endgroup$
    – kglr
    May 19, 2012 at 20:34
  • 1
    $\begingroup$ ... also see @Szabolcs' Locator3D... Thanks to Jens for the link. $\endgroup$
    – kglr
    May 19, 2012 at 23:47
  • 2
    $\begingroup$ Can you clarify a bit what you mean by "add locators to each set of points"? First I thought you need to move each locator on one of the three planes on the plot, but you said kguler's is not what you need. Also, you could you explain what you mean by "The Locators should move the points on the grid, and affect the other surrounding points"? Do you mean that the locator moving on surface 1 (defined by point set 1) should distort the locations of the points in set 2 when it moves near them? If yes, how exactly? $\endgroup$
    – Szabolcs
    May 24, 2012 at 8:26
  • 1
    $\begingroup$ It sounds like some kind of "surface editor", where it's possible to shape an elastic surface. So for a basic example, one dataset is enough, and it's not necessary to have three. Is this correct? $\endgroup$
    – Szabolcs
    May 24, 2012 at 14:28

3 Answers 3

Reset to default
20
+100
$\begingroup$

I'm not sure if this comes close to what you had in mind, but I hope it helps.

Moving a sphere will move the other spheres as well. The distance over which the spheres are moved depends on their strength, the strength of the sphere being moved and the distance between the two spheres. The size of the spheres indicates their strength.

The function translateList governs the movement of the spheres where crds is the list of old coordinates, strs the list of strengths of the spheres, index the index of the sphere that is being moved, and posnew is the new position of the point being moved. translateList returns a list of the new positions of the points.

DynamicModule[{bb, pts, normal, strengths, index, pos0, pos1, translateList},
 index = 0;
 normal = {0, 0, 1};
 pts = ArrayPad[Tuples[Range[-2, 2, .5], 2], {{0, 0}, {0, 1}}];
 strengths = RandomReal[1, Length[pts]];
 
 translateList[crds_, strs_][index_, posnew_] :=
  Function[{c0, str0},
    If[c0 === crds[[index]],
     posnew,
     With[{factor = strs[[index]] (1 - str0)/(1 + Norm[crds[[index]] - c0])},
      c0 + factor (posnew - crds[[index]])]]] @@@ Transpose[{crds, strs}];
 
 EventHandler[
  Graphics3D[
   {{Plot3D[0, {x, -2, 2}, {y, -2, 2},
       Mesh -> {Range[-2, 2, .5], Range[-2, 2, .5]},
       MeshStyle -> {{Orange}}, BoundaryStyle -> {Orange}][[1]]},
    Dynamic[{ListPointPlot3D[pts, Filling -> 0, 
        FillingStyle -> Directive[{Thick, Orange, Dashed}]][[1]]}],
    EventHandler[
       Mouseover[
        {Dynamic[If[index === #, Red, Green]], 
         Sphere[Dynamic[pts[[#]]], (.5 + strengths[[#]])/8]},
        {Dynamic[If[index === 0 || index === #, Red, Green]], 
         Sphere[Dynamic[pts[[#]]], (.5 + strengths[[#]])/8]}],
       
       {"MouseDown" :> (index = #; pos0 = pts[[index]])},
       PassEventsUp -> True] & /@ Range[Length[pts]]},
   PlotRange -> {-3, 3}, PlotRangePadding -> .5, ImageSize -> 600],
  {"MouseDragged" :> If[index > 0,
     pos1 = LeastSquares[Transpose[{#1 - #2, normal}], #2 - pos0][[2]] normal + 
         pos0 & @@ MousePosition["Graphics3DBoxIntercepts"];
     pts = translateList[pts, strengths][index, pos1]],
   "MouseUp" :> (pts[[All, 3]] = Clip[pts[[All, 3]], {-3.5, 3.5}]; index = 0)},
  PassEventsDown -> True]]

Mathematica graphics

Updated version

This is a rather rigorous overhaul of the code above. The strength of the control point can now be set with a slider. The amount by which a point is being moved depends on the horizontal distance of that point to the control point and the strength of the control point. The surface through the points is now dynamically updated.

DynamicModule[{bb, pts, normal, i0, ilist, pos1, drag, translateList, 
  plot},
 normal = {0, 0, 1};
 pts = ArrayPad[Tuples[Range[-2, 2, .5], 2], {{0, 0}, {0, 1}}];
 drag = False;
 ilist = {};
 i0 = 0;
 translateList[crds_, str_, i0_, posnew_] :=
  Function[c0,
    If[c0 === crds[[i0]], posnew, 
     With[{factor = 
        Clip[1 - Norm[c0[[;; 2]] - crds[[i0, ;; 2]]]^2/(str)^2, {0, 
          10}]}, c0 + factor (posnew - crds[[i0]])]]] /@ crds;
 
 Manipulate[
  Graphics3D[
   EventHandler[
    {{Which[# === i0, Red, MemberQ[ilist, #], Blue, True, Green],
        Sphere[Dynamic[pts[[#]]], .12]} & /@ Range[Length[pts]],
     
     Dynamic[
      ListPlot3D[pts, Mesh -> {Range[-2, 2, .5], Range[-2, 2, .5]}, 
        MeshStyle -> {{Orange}}, BoundaryStyle -> {Orange}, 
        PlotRange -> All, PerformanceGoal -> "Quality"][[1]]]},
    
    {"MouseMoved" :> (If[Not[drag],
        i0 = Nearest[Transpose[Transpose[pts] - #1] -> Automatic, #2 - #1,  
             DistanceFunction -> (Norm[#1 - Projection[#1, #2]] &)][[1]] & @@ 
              MousePosition["Graphics3DBoxIntercepts"];
        ilist =  Flatten[Position[pts, a : {___?NumericQ} /; 
            Norm[a[[;; 2]] - pts[[i0, ;; 2]]] < strength]]]
       ),
     
     "MouseDown" :> (
       i0 = Nearest[Transpose[Transpose[pts] - #1] -> Automatic, #2 - #1, 
            DistanceFunction -> (Norm[#1 - Projection[#1, #2]] &)][[1]] & @@
             MousePosition["Graphics3DBoxIntercepts"];
       If[(Norm[pts[[i0]] - #1 - Projection[pts[[i0]] - #1, #2 - #1]] &
           @@ MousePosition["Graphics3DBoxIntercepts"]) < .2, 
        drag = True];
       ilist = Flatten[Position[pts, a : {___?NumericQ} /; 
           Norm[a[[;; 2]] - pts[[i0, ;; 2]]] < strength]]
       ),
     "MouseDragged" :>
      If[drag, (pos1 = 
         LeastSquares[Transpose[{#1 - #2, normal}], #2 - pts[[i0]]][[
              2]] normal + pts[[i0]] & @@ 
          MousePosition["Graphics3DBoxIntercepts"];
        pts = translateList[pts, strength, i0, pos1])],
     "MouseUp" :> (
       ilist = {}; i0 = 0;
       drag = False; 
       pts[[All, 3]] = Clip[pts[[All, 3]], {-3.5, 3.5}])
     }, PassEventsDown -> False],
   PlotRange -> {{-2.5, 2.5}, {-2.5, 2.5}, {-3, 3}}, 
   ImageSize -> 450],
  {{strength, 1}, .1, 5}]]

Mathematica graphics

Improve this answer
$\endgroup$
11
  • 1
    $\begingroup$ Excellent! I was thinking of something similar except without the spheres influencing each other (I know it was in the question). I wasn't sure how to handle intuitive vertical dragging properly though. I'd give you +2 if I could. $\endgroup$
    – Szabolcs
    May 26, 2012 at 19:39
  • 1
    $\begingroup$ @Szabolcs Thanks. It took me a while to get the movement right but I'm quite happy with the result. $\endgroup$
    – Heike
    May 26, 2012 at 19:45
  • $\begingroup$ @Heike Very cool implementation! Problems here may be easy to resolve. The points on the grid seem to have predefined strengths. What's needed is the selected point have a variable strength as mentioned above. If there was a calculation for the strength of each sphere based on it's location to the selected sphere and the strength amount for the selected point. Also the boundary points move and should not unless the strength is large enough to encompass them. I agree, Certainly very helpful, +2 if I could! $\endgroup$
    – Nothingtoseehere
    May 26, 2012 at 20:59
  • 1
    $\begingroup$ @RHall I'm not sure what you mean. In translateList, factor indicates by how much the points are being moved as a fraction of the distance by which the selected point is being moved. For a point with strength str0 at position c0, factor is equal to factor = str1 (1 - str0)/(1 + Norm[c1 - c0]) where str1 and c1 are the strength and coordinates of the selected point, so factor already depends on the distance between the two points. If you want to keep the points on the boundary fixed, you could for example multiply it with something like Erf[4 - c0[[1]]^2] Erf[4- c0[[2]]^2] $\endgroup$
    – Heike
    May 27, 2012 at 6:41
  • $\begingroup$ @Heike Yes that is clear but having each point at a random strength was not a need or requirement. What is needed is to have a single selected point be changed by a value and the surrounding points be affected depending on the strength amount used. In this implementation there is no provision for that. Amazing work though and probably the best interface for this purpose I have seen. Thank you! $\endgroup$
    – Nothingtoseehere
    May 29, 2012 at 0:21
11
$\begingroup$

LATEST VERSION

Well, now it seems like I have more robust implementation.

enter image description here

The sphere shows the "strength" of current node and can be switched off using the checkbox. The strength can be adjusted with horisontal slider. All remaining functionality is taken from the first version below.

More pictures: enter image description here enter image description here

The code:

DynamicModule[{n = 7, pts, bb, pp, dp, ai, f, b, infl, b0, dist, strs,
   ss = True},
 pts = Flatten[Table[{i, j, 0}, {i, n}, {j, n}], {1, 2}] // N;
 strs = Table[1, {n^2}];
 bb = {{-1, n + 2}, {-1, n + 2}, {-4, 4}};
 ai = 1; pp = pts[[ai]];
 dist = Function[{f, b, p}, 
   1 - Abs[(f - b).(p - b)/(Norm[f - b] Norm[p - b])]];
 b0 = 1/BSplineBasis[2, 0.5];
 infl[d_, r_] := If[d == 0, 0, b0 BSplineBasis[2, d/(3 r ) + 0.5]];
 With[{p = Hold@pts[[ai]], r = Hold[strs[[ai]]],
    x = Hold@pts[[ai, 1]], y = Hold@pts[[ai, 2]], 
    z = Hold@pts[[ai, 3]]},
   Panel@Row[{
      EventHandler[
       Dynamic[
        dp = p - pp; pts = (# + dp infl[Norm[p - #], r]) & /@ pts; pp = p;
        Show[
         ListPlot3D[pts, PlotStyle -> {Opacity[0.7]}, Mesh -> False, 
          PlotRange -> bb], 
         Graphics3D[{Blue, PointSize[0.02], Point@pts, Orange, 
           Point@p, Opacity[0.4], ss~If~Sphere[p, r], Opacity@1, 
           Dashed, Gray, Thickness[Large],
           Line[{{x, bb[[2, 1]], bb[[3, 1]]}, {x, bb[[2, 2]], 
              bb[[3, 1]]}}],
           Line[{{bb[[1, 1]], y, bb[[3, 1]]}, {bb[[1, 2]], y, 
              bb[[3, 1]]}}],
           Line[{p, {x, y, bb[[3, 1]]}}]}
          ],
         BoxRatios -> Automatic, Axes -> True, PlotRange -> bb, 
         ImageSize -> 420, Background -> White]
        ],
       {{"MouseClicked", 2} :> (
          {f, b} = MousePosition["Graphics3DBoxIntercepts"];
          ai = Ordering[pts, 1, dist[f, b, #1] < dist[f, b, #2] &][[1]];
          pp = p;
          )}
       ],
      Column[{Checkbox@Dynamic@ss,
        Slider[Dynamic@r, {.1, 20, 0.01}],
        VerticalSlider[Dynamic@z, {-2, 2}],
        Slider2D[Dynamic@{x, y}, {0, n + 1}, ImageSize -> {150}]},
       Alignment -> Center]
      }, Spacer@10, Alignment -> Center]
   ] // ReleaseHold
 ]

OLD VERSION

DynamicModule[{n, pts, bb, ai, r, f, b},
 n = 4;
 pts = Flatten[Table[{i, j, 0}, {i, n}, {j, n}], {1, 2}] // N;
 bb = {{0, n + 1}, {0, n + 1}, {-2, 2}};
 ai = 1; r = 0.1;
 dist = Function[{f, b, p}, 
   1 - Abs[(f - b).(p - b)/(Norm[f - b] Norm[p - b])]];
 Panel@Row[
   {EventHandler[
     Dynamic@Show[
       ListPlot3D[pts, PlotStyle -> {Opacity[0.7]}, Mesh -> False, PlotRange -> bb],
       Graphics3D[{
         Blue, PointSize[0.02], Point@pts, Orange, Opacity[0.7], 
         Sphere[pts[[ai]], r],
         Dashed, Gray, Thickness[Large],
         Line[{{pts[[ai, 1]], bb[[2, 1]], bb[[3, 1]]}, {pts[[ai, 1]], 
            bb[[2, 2]], bb[[3, 1]]}}],
         Line[{{bb[[1, 1]], pts[[ai, 2]], bb[[3, 1]]}, {bb[[1, 2]], 
            pts[[ai, 2]], bb[[3, 1]]}}],
         Line[{pts[[ai]], {pts[[ai, 1]], pts[[ai, 2]], bb[[3, 1]]}}]
         }],
       BoxRatios -> Automatic, Axes -> True, PlotRange -> bb, 
       ImageSize -> 420, 
       Background -> White], {{"MouseClicked", 
        2} :> ({f, b} = MousePosition["Graphics3DBoxIntercepts"]; 
        ai = Ordering[pts, 1, dist[f, b, #1] < dist[f, b, #2] &][[1]])
      }
     ],
    Column[{
      VerticalSlider[Dynamic@pts[[ai, 3]], {-2, 2}],
      Slider2D[Dynamic@{pts[[ai, 1]], pts[[ai, 2]]}, {0, n + 1}, 
       ImageSize -> {150}]
      }, Alignment -> Center]
    }, Spacer@10, Alignment -> Center
   ]
 ]

The result is

enter image description here

The active point is selected via right-click, the vertical position of the selected point is adjusted with VerticalSlider, the position in XY plane is controlled by Slider2D. Some more screenshots:

enter image description here

enter image description here

Improve this answer
$\endgroup$
6
  • $\begingroup$ Excellent start! What I see is some of the points don't actually move but limit the deformation of the form and this assumes a single (or smaller) change strength. Variable strength will allow all the points not on the boundary of the list to deform in any direction since these lists may be shapes. The result of the change should be the new list returned with the deformed values. $\endgroup$
    – Nothingtoseehere
    May 25, 2012 at 20:53
  • $\begingroup$ Very nice, +1. Dragging the point directly in the graphic would have been much more problematic even if their movement is restricted to the $z$ axis, and you came up with an easy to use and precise alternative UI. One problem is that sometimes I do get a cutoff on the plot, as if something were wrong with the vertical plot range: example $\endgroup$
    – Szabolcs
    May 26, 2012 at 19:36
  • 1
    $\begingroup$ @Szabolcs, thank you! The cutoff problem can be fixed by adding proper PlotRange to ListPlot3D. I'll do it in few seconds. $\endgroup$
    – faleichik
    May 26, 2012 at 20:10
  • $\begingroup$ @faleichik Well done +1, The only functionality that's missing it strength. At present adjustments are limited to areas between points. Adding the strength adjustment allows as many points as needed to be moved smoothly in a single change to the surface. $\endgroup$
    – Nothingtoseehere
    May 27, 2012 at 9:59
  • $\begingroup$ @faleichik Well done, but on 8.04 it appears that moving the locator around the plane scatters the points. But Oh so close to perfect here. I love the strength bubble. Very easy to visualize which points will be affected! $\endgroup$
    – Nothingtoseehere
    May 29, 2012 at 0:16
10
$\begingroup$

Not meant as an answer to the question, but MousePosition["Graphics3DBoxIntercepts"] will be the key piece one will need in a full answer. Possibly inside an EventHandler as in @Szabolcs's MathGroup post for moving a point on a 3D surface. (Please hold onto your votes till Szabolcs posts his own answer.)

fun[x_, y_] := x^2 + y^2;

DynamicModule[{f, b},
 EventHandler[
  Show[
   Plot3D[fun[x, y], {x, -1, 1}, {y, -1, 1}],
   Graphics3D[
    Dynamic @ Quiet @ 
      Check[
       Sphere[((f - b) t + f) /. 
         FindRoot[fun[#1, #2] == #3 & @@ ((f - b) t + f), {t, 0}], .1],
       {}
      ]
   ],
   BoxRatios -> {1, 1, 1}],
  {"MouseMoved" :> ({f, b} = MousePosition["Graphics3DBoxIntercepts"])}
 ]
]

screenshot:

enter image description here

Improve this answer
$\endgroup$
7
  • $\begingroup$ thanks very much for the attempt. I hope I was clear that by locator I meant something like this: Manipulate[ Graphics[Line[{{0, 0}, p}], PlotRange -> 2], {{p, {1, 1}}, Locator}] to make one or more of the points move in these lists. So as to change the shape of each surface. $\endgroup$
    – Nothingtoseehere
    May 19, 2012 at 21:10
  • 1
    $\begingroup$ @RHall, I should have noted that my "answer" was meant as a pointer for the pieces needed to build something that fully addresses the requirements in your question. $\endgroup$
    – kglr
    May 19, 2012 at 21:16
  • $\begingroup$ this is certainly an elegant looking GUI for the process. Thank you! $\endgroup$
    – Nothingtoseehere
    May 19, 2012 at 21:20
  • 1
    $\begingroup$ @RHall, I agree:) thanks to the yet-to-be-identified owner. $\endgroup$
    – kglr
    May 19, 2012 at 21:27
  • 2
    $\begingroup$ Looks like the code came from szabolcs on Mathgroup. $\endgroup$
    – Jens
    May 19, 2012 at 22:13

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.