6
$\begingroup$

how would I create a Manipulate to draw a InfiniteLine between two Locator? The first Loactor should control the x/y of the first point together with the y of the second one. The second Locator should control x/y of the second point only.

In other words the first Locator should parallel shift the line in y, the second one change the slope.

This is what I tried so far (track the changes of first point y and update second point):

 Manipulate[
 Graphics[
   If[p1[[2]] =!= old,
     p2[[2]] += p1[[2]] - old;
     old = p1[[2]];
     ];
 
  InfiniteLine[{p1, p2}],
  PlotRange -> 4 {{-1, 1}, {-1, 1}}
  ],
 {{old, 0}, ControlType -> None},
 {{p1, {0, 0}}, Locator},
 {{p2, {2, 1}}, Locator}
 ]

enter image description here

This "works" somehow but only when just slowly dragging the first point, otherwise it gets garbled.

Any hints wellcome.

Hello I came up with a new trial.

Manipulate[
 Graphics[{InfiniteLine[{pt[[1]], pt[[2]]}]}, PlotRange -> 2],
 {{pt, {{-1, 0}, {1, 0}}}, Locator,
  TrackingFunction -> (pt = {#[[1]], #[[2]] + #[[1]] - pt[[1]]}; &)}]

The Idea is to detect delta movement of the first point an add it to the second one to keep the slope constant when moving the first point, done via the TrackingFunction option. Delta "should be" calculated by subtracting the old value pt[1] from the actual value #[1] both of the first point.

Somehow this still does not work, the longer you drag the more error bulds up. While @kglr solution is running smooth I am still curious why ma attempt fails.

$\endgroup$
1
11
$\begingroup$

Update 2: A variation on RobertNovak`s answer to keep the horizontal axis of the second locator fixed:

tF[p : {{x1_, y1_}, {x2_, y2_}}] := If[#[[1, 1]] != #[[2, 1]], 
    If[CurrentValue["CurrentLocatorPaneThumb"] == 2, #, 
       {#[[1]], {x2, #[[1, 2]] + (x2 - #[[1, 1]]) (y1 - y2)/(x1 - x2)}}], p] &;

Manipulate[Graphics[{InfiniteLine @ pt, Opacity[0], 
    MapThread[MouseAppearance[Point@#, #2] &, {pt, {"PanView", "RotateViewVertical"}}]},
   PlotRange -> 2, 
   GridLines -> {{{pt[[2, 1]], Dashed}}, None}], 
 {{pt, {{-1, 0}, {1, 1}}}, Locator, TrackingFunction -> (pt = tF[pt]@#; &), 
   Appearance -> (Style["\[EmptyCircle]", 24, Bold, #] & /@ {Red, Blue})}]

enter image description here

Update: Using a single control with multiple locators, we specify the updates based on the active locator:

Manipulate[Graphics[{InfiniteLine @ pt}, PlotRange -> 2, 
    GridLines -> {{{pt[[2, 1]], Dashed}}, None}],
 {{pt, {{-1, 0}, {1, 1}}}, Locator, 
  TrackingFunction -> (If[CurrentValue["CurrentLocatorPaneThumb"] == 2, 
       pt = #;, 
       pt = {#[[1]], pt[[2]] + #[[1]] - pt[[1]]}]; &), 
  Appearance -> (Style["■", 24, #] & /@ {Red, Blue})}]

enter image description here

Original answer:

You can use DynamicModule and Locator with two-argument form of Dynamic:

DynamicModule[{p1 = {0, 0}, p2 = {2, 1}, old = {0, 0}}, 
 Deploy @ Dynamic @
   Graphics[{InfiniteLine[{p1, p2}], 
     Locator[Dynamic[p1, (p1 = #; p2 += p1 - old; old = p1;) &]], 
     Locator[Dynamic[p2]]}, 
    GridLines -> {{{p2[[1]], Dashed}}, None}, 
    Frame -> True, FrameTicks -> None,
    PlotRange -> 4 {{-1, 1}, {-1, 1}}]]

enter image description here

If you have to use Manipulate:

Manipulate[Graphics[{InfiniteLine[{p1, p2}], 
   Locator[Dynamic[p1, (p1 = #; p2 += p1 - old; old = p1;) &]], 
   Locator[Dynamic[p2]]},
  PlotRange -> 4 {{-1, 1}, {-1, 1}}],
 {{old, {0, 0}}, None}, {{p1, {0, 0}}, None}, {{p2, {2, 1}}, None}]

enter image description here

$\endgroup$
4
  • $\begingroup$ Thanks a lot but I would like the first point not to alter the slope. This could be done either by fixing the x of the first point or by adding any movement of point 1 to point 2. $\endgroup$ Sep 8 at 16:20
  • $\begingroup$ @RobertNowak, please see the updated version. $\endgroup$
    – kglr
    Sep 8 at 16:59
  • $\begingroup$ Great. @kglr how do you create the gif animation? thx & regards $\endgroup$ Sep 8 at 22:45
  • $\begingroup$ @RobertNowak, I use ScreenToGIF. $\endgroup$
    – kglr
    Sep 8 at 22:55
3
$\begingroup$

Finaly thanks to @kglr the locators move in the most intuitive way. The second point now only moves in y while the first one is draged arround.

Manipulate[Graphics[{InfiniteLine@pt}, PlotRange -> 2],
 {{pt, {{-1, 0}, {1, 1/2}}}, Locator,
  TrackingFunction -> (With[{t = 
         Apply[Divide]@Reverse[pt[[2]] - pt[[1]]]},
       pt = If[#[[2, 1]] != #[[1, 1]],
         {#[[1]], 
          If[CurrentValue["CurrentLocatorPaneThumb"] == 2, #[[
            2]], {pt[[2, 1]], 
            pt[[2, 2]] + #[[1, 2]] - pt[[1, 2]] - 
             t (#[[1, 1]] - pt[[1, 1]])}]},
         pt]
       ]; &),
  Appearance -> {Style["✥", Large], Style["®", Large]}}
 ]
 

enter image description here

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