How to dynamically update Locator[] constraints?

Question

I need to visualize Menelaus' theorem for a triangle with moving locators for each of six points. So the vertexes of the triangle can move in any possible way, and the three points on the sides of the triangle can not - they should be fixed on the side.

I've tried manipulating stuff, but I cant merge the Manipulate with

Locator[Dynamic[pa1, (pa1 = ToTheLine[#, pb, pc]) &]]

So I've come to this:

ToTheLine[p_, lb_, le_] :=
  {
    p[[1]], 
    If[le[[1]] == lb[[1]],
      p[[2]],
      lb[[2]] - (lb[[1]] - p[[1]])*(le[[2]] - lb[[2]])/(le[[1]] - lb[[1]])]
  }

DynamicModule[{
  pa = {-5, 0}, pb = {5, 0}, pc = {0, 10},
  pa1 = (pb + pc)/2, pb1 = (pa + pc)/2, pc1 = (pb + pa)/2},
  (* point pa1 is labeled as D and is on side BC of the triangle, 
     similar definition for the others *)
  Graphics[{
      Locator[Dynamic[pa]], (* point A *)
      Locator[Dynamic[pb]], (* point B *)
      Locator[Dynamic[pc]], (* point C *)
      Locator[Dynamic[pa1, (pa1 = ToTheLine [#, pb, pc]) &]],
      Locator[Dynamic[pb1, (pb1 = ToTheLine [#, pc, pa]) &]],
      Locator[Dynamic[pc1, (pc1 = ToTheLine [#, pb, pa]) &]],
      Text[Style["A", 20, "Label"], Dynamic[pa + {0, 1}]],
      Text[Style["B", 20, "Label"], Dynamic[pb + {0, 1}]],
      Text[Style["C", 20, "Label"], Dynamic[pc + {0, 1}]],
      Text[Style["D", 10, "Label"], Dynamic[pa1 + {0, 1}]],
      Text[Style["E", 10, "Label"], Dynamic[pb1 + {0, 1}]],
      Text[Style["F", 10, "Label"], Dynamic[pc1 + {0, 1}]],
      Thick, Red, 
      Line [{Dynamic[pa], Dynamic[pb], Dynamic[pc], Dynamic[pa]}],
      Thin, Black,
      Line [{Dynamic[pa], Dynamic[pc1]}],
      Line [{Dynamic[pb], Dynamic[pa1]}],
      Line [{Dynamic[pc], Dynamic[pb1]}],
      Line [{Dynamic[pa1], Dynamic[pb1]}],
      Line [{Dynamic[pb1], Dynamic[pc1]}]},
    PlotRange -> 20.
    Axes -> True.
    ImageSize -> 600]]

The function ToTheLine just gets locator coords and puts the points on a line defined by two other points.

When I drag a point on the side and then drag vertex, the point doesnt stay on side anymore. I tried Locator[Dynamic[pc1, (pc1 = ToTheLine [#, Dynamic[pb], Dynamic[pa]]) &]], which uses correct coords for A and B, but there is some error there.

How can I solve this problem? Is there a far more elegant solution?

Answer 1

First I address the general solution, and below treat the particular case of your example.

Make a list of locators in a particular order such as

locators = { tri1, tri2, tri3, opp1, opp2, opp3 }

where the tri are the coordinates of the triangle and the opp are the coordinates of the points on the side opposite the respective vertex. Note in Menelaus theorem, at least one point lies on the extension of a side.

Next, each time one of the locators is moved, the list of all six points needs to be updated. I'd suggest using a function like

newConfig[loc_List, {{}}] := loc;
newConfig[loc_List, {{moved_}}] := ...

The variable moved will be the index (returned by Position below) of the locator in the list of points loc that moved. The function newConfig would compute a new configuration depending on which one moved. In your case, it could constrain the opp locators to lie on a line.

The general structure of the Manipulate would be

Manipulate[
 LocatorPane[
  Dynamic[locators, (locators = newConfig[#, Position[locators - #, Except[{0., 0.}], {1}, 1, Heads -> False]]) &],
  Dynamic@Graphics[{(* graphics for figure *)}]
 ],
 {{locators, ..(* init.config.*)}, None}]

If you'd prefer DynamicModule you could use that instead of Manipulate, but it is possible to use Manipulate.

---

Example: Menelaus' Theorem

First, the configuration of the locators: the points are ordered so that if locator[[i]] is a vertex of the triangle, then locator[[i+3]] is on the opposite side.

Second, whenever a locator is moved, two points need updating. When the locator is a vertex of the triangle, the points are the nonvertices on the adjacent sides. When the locator is a point on a side, the points are one of the other side points and the locator itself; which side point is arbitrary but determines the behavior. Below, I made a cyclic choice so that the behavior has a somewhat symmetric feel. Which points need updating when a given point is moved is encoded in the list of rules $movedToUpdate.

  (* moving a point causes others to need updating according to the following rules *)
$movedToUpdate = {1 -> {5, 6}, 2 -> {4, 6}, 3 -> {4, 5},
   4 -> {5, 4}, 5 -> {6, 5}, 6 -> {4, 6}};

  (* finds the intersection of a line = {p1, p2} and its conjugate, line+3 *)
lineEq[twopoints_] := 
  Det[Transpose[twopoints~Join~{{x, y}}]~Join~{{1, 1, 1}}] == 0;
intersection[points_, line_] :=
  {x, y} /. First@Solve[{lineEq[points[[line]]], lineEq[points[[line + 3]]]}, {x, y}];

  (* initial configuration of locators; last point determined by intersection *)
$initConfig = {{0., 0.5}, {-0.5, -0.5}, {0.5, -0.5}, {0.75, -0.5}, {0.25, 0.}};
$initConfig = $initConfig~Join~{intersection[$initConfig, {1, 2}]};

newConfig[locs_, {{}}] := locs; (* in case of dynamic update when no locators moved *)
newConfig[locs_, {{moved_}}] :=
 Fold[ReplacePart[#1, #2 -> intersection[#1, DeleteCases[Range[3], Mod[#2, 3, 1]]]] &,
      locs, moved /. $movedToUpdate];

Manipulate[
 LocatorPane[
  Dynamic[locators,
    (locators = newConfig[#, Position[locators - #, Except[{0., 0.}], {1}, 1, Heads -> False]]) &],
  Dynamic@Graphics[
    GraphicsComplex[locators,
     {Line[{{4, 2, 3}, {1, 5, 3}, {1, 2, 6}, {4, 5, 6}}],
      Red, Line[{1, 2, 3, 1}], PointSize[Large], Red, Point[Range[6]]}],
    PlotRange -> 1]
  ],
 {{locators, $initConfig}, None}]

Answer 2

d = Dynamic;
s[{x_, i_, y_}] := Text[Style[x, 10 i, "Label"], Dynamic[y + {0, 1}]]
toLine[pt_, start_, end_] := Module[{param = ((pt-start).(end-start))/Norm[end-start]^2}, 
                                    start + Clip[param, {0, 1}] (end - start)]
DynamicModule[{
  pa  = {-5, 0},     pb = {5, 0},       pc  = {0, 10},
  pa1 = (pb + pc)/2, pb1 = (pa + pc)/2, pc1 = (pb + pa)/2},
 {Dynamic[pa1 = toLine[pa1, pb, pc]; pb1 = toLine[pb1, pa, pc]; pc1 = toLine[pc1, pb, pa];],
  Graphics[{
    s/@{{"A",2,d@pa},{"B",2,d@pb}, {"C",2,d@pc},{"D",1,d@pa1}, {"E",1,d@pb1}, {"F",1,d@pc1}},
    Thick, Red,  Line @ {d@pa, d@pb, d@pc, d@pa},
    Thin, Black, Line @ {d@pa, d@pc1, d@pb1, d@pc, d@pb1, d@pa1, d@pb},
    Locator /@          {d@pa, d@pc1, d@pb1, d@pc, d@pb1, d@pa1, d@pb},
    PlotRange -> 20, Axes -> True, ImageSize -> 600}]}]