Skip to main content

dynamic - How to efficiently drag points on a curve within a Manipulate


My intention is to demonstrate on any conic various metrics properties on points belonging to the conic and connected by lines.
I want the points to be dynamically moved not the usual way, indirectly with the help of any Manipulate controls like Slider, but by an artifice, hiding the Locator control object and let one feel that by dragging any point on the curve you manipulate directly that point (though of course it is the locator that you manipulate).
Here is my embryonic code so far, just a circle with two points (and I made here the 2 locators visible):


findY[ptX_] := Module[{},
Which[((First[ptX] <= 0 && ptX[[2]] <=  0) || (First[ptX] > 0 && 
   ptX[[2]] <=  0) ),                  

   y /. Solve[x^2 + y^2 == 4, {y}][[1]] /. {x -> First[ptX]},
             ((First[ptX] <= 0 && 
   ptX[[2]] >  0) || (First[ptX] > 0 && ptX[[2]] >  0) ) ,                  
     y /. Solve[x^2 + y^2 == 4, {y}][[2]] /. {x -> First[ptX]}]]

Manipulate[
{{Style[StringForm[
 "Locator for the blue point `1` Blue point coords{`2`,`3`}", 
 Dynamic[ptA], First[ptA], findY[ptA]]]},
{Style[StringForm[

 "Locator for the green point `1` Green point coords{`2`,`3`}", 
 Dynamic[ptB], First[ptB], findY[ptB]]]}}, 
Row[{LocatorPane[Dynamic[{ptA, ptB}], 
ContourPlot[x^2 + y^2 == 4, {x, -3, 3}, {y, -3, 3}, 
 PlotRange -> Automatic, AspectRatio -> 1, Axes -> True, 
 Frame -> None, ImageSize -> 300, 
 Epilog -> {{PointSize[Large], Blue,  
    Point[Dynamic[{First[ptA], findY[ptA]}]]},
                     {PointSize[Large], Green, 
    Point[Dynamic[{First[ptB], findY[ptB]}]]}}],

Appearance -> Style["\[CirclePlus]", 20, Red]]}], 
(* Replace with Appearance->None to hide the Locators *)
{{ptA, {-2, 0}},None}, {{ptB, {2, 0}}, None}] (* ptA Blue ptB Green *)

You can see that by clicking on any of the two locators each point will move along the whole circle, even cross each other: if you move your mouse slowly the locator will stay very close to the point but if you do it too quickly the point will move too but the locator may be far off giving an erratic effect to the movement of the point.
And an issue too, having difficulty of retrieving it then with your mouse if the locator is not visible.
My question: On a PC when you want to drag a point which is to be moved along a curve, you start by clicking on the point and then dragging where you want it to be (and not something else). Can the same effect be obtained be obtained with MMA? If internally this means dragging a MMA Locator it should be as far as possible transparent.


I took pains to check that my question is not a duplicate,sorry if it is. Errare humanum est.



In short: How can I constrain a locator to move along a curve, similar to the goal in Constrain movement of a locator inside Manipulate, except that here the curve is defined by an equation instead of parametrically?




Answer



Here's a way to constrain the locators to the curve. We use ContourPlot to generate a list of points on the curve; the nearest one, returned by the NearestFunction nf, is used as a starting point for FindRoot to solve for the nearest point on the curve.


Clear[findP, loc];
findP[p0_, conicEqn_, {x0_, y0_}] :=
  {x, y} /. FindRoot[
    {Cross[{x, y} - p0].D[Subtract @@ conicEqn, {{x, y}}] == 0, 
     conicEqn},
    {{x, x0, -3, 3}, {y, y0, -3, 3}},
    AccuracyGoal -> 3, PrecisionGoal -> 4];


loc[Dynamic[pts_], conic_] := DynamicModule[{nf},
   nf = Nearest[Cases[
      ContourPlot[conic, {x, -3, 3}, {y, -3, 3}, PlotPoints -> 100, 
        MaxRecursion -> 4, Axes -> None, Frame -> None],
      {_Real, _Real}, Infinity]];
   pts = findP[#, conic, First@nf[#]] & /@ pts;
   Row[
    {LocatorPane[
      Dynamic[pts, (pts = findP[#, conic, First@nf[#]] & /@ #) &], 
      Dynamic@ContourPlot[conic,

        {x, -3, 3}, {y, -3, 3},
        AspectRatio -> 1, Axes -> True, Frame -> None, 
        ImageSize -> 200],
      Appearance -> Style["\[CirclePlus]", 20, Red]]}
    ]
   ];

Manipulate[{ptA, ptB},
 {{conic, x^2 + y^2 == 4}, InputField},
 Dynamic@Refresh[

   loc[Dynamic[{ptA, ptB}], conic],
   TrackedSymbols :> {conic}],
 {{ptA, {-2, 0}}, None}, {{ptB, {2, 0}}, None}
 ]

Mathematica graphics


Mathematica graphics


Comments

Post a Comment

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more