Group Abstract Group Abstract

Message Boards Message Boards

0
|
4.4K Views
|
1 Reply
|
0 Total Likes
View groups...
Share
Share this post:

Quest for equilateral triangles of triples of points

Posted 11 years ago

Let $\Omega$ be a simply connected two dimensional region, for simplicity a rectangle. Consider $n \geq 3$ points. Define once randomly triples of these points (not necessarily pairwise disjunct) in such a way, that each point $p_i$ watches two other points $p_j, p_k$ $(i \neq j , j \neq k,i \neq k)$ and quests to form an equilateral triangle with them.

To do so $p_i $ moves a step into direction to the target position needed. But $p_j$ watches two other points (not necessarily $p_i$ and/or $p_k$) and quests to form with them an equilateral triangle (within $\Omega$). The same holds for $p_k$.

What do you think is the outcome e.g. in the unit square?

Do we see after a time a collection of moving equilateral triangles or even do the equilateral triangles stop moving? Or do the points never become all arranged into equilateral triangles? For the sake of simplicity the velocity of all points is equal and constant (or zero). Also two or more points can hold the same position in $\Omega$, they do not collide and do not bounce each other. If a point is nearer to its target position in its equilateral triangle it does only this smaller step to reach the target position. If a points has a position as corner of an equilateral triangle it stops moving iff the two points it watches do also not move. The points do not bounce from $\partial \Omega$ but hold on it moving from there back into $\Omega$ or along $\partial \Omega$ with the next step.

What happens for $n=3$?

POSTED BY: Udo Krause

One can do the following

Remove[equiLaterator]

equiLaterator::offcolor = "`1` is not an indexed color data entry.";
equiLaterator::shortage = 
  "`1` points in `2` dimensions cannot create a simplex.";
equiLaterator::separation = 
  "Selected simplices do not have maximal separation.";
equiLaterator::deflate = 
  "Lower dimensional simplices persist even after `1` iterations.";
equiLaterator::inflate = 
  "It took `1` iterations to avoid lower dimensional simplices.";
equiLaterator::multiplicity = 
  "Edges belonging to multiple simplices: `1`";

Options[equiLaterator] = {
     Iterations -> 5000,
     LabelStyle -> Directive[Black, 14, Bold],
     LabelOffset -> {-1, -1}
   };

equiLaterator[
     d_Integer?Positive (* dimension *),
     n_Integer?Positive (* number of points *),
     cub_Integer?Positive(* cube in dimension *),
     opts : OptionsPattern[]
   ] /; n < d + 1 := (
    Message[equiLaterator::shortage, n, d];
    $Failed
  )

equiLaterator[
    d_Integer?Positive (* dimension *),
    n_Integer?Positive (* number of points *),
    cub_Integer?Positive (* cube in dimension *),
    opts : OptionsPattern[]
  ] := DynamicModule[
   {
    rn = Range[n],
    idx,
    idxAss,
    maxIt = 2 n^2,
    o = 0,
    pts,
    simplices,
    colNr = 59,
    colors,
    oo = 0,
    doneQ = False,
    tol = 10^-6,
    maxIter = OptionValue[Iterations],
    labelStyle = OptionValue[LabelStyle],
    labelOffset = OptionValue[LabelOffset]
    },

   idx = NestList[RandomSample[#, n] &, rn, d];
   (* RandomSample[{e1,e2,\[Ellipsis]},
   n] never samples any of the e_(i) more than once: 
   maximal separation *)
   While[
    DeleteDuplicates[
       Length /@ (DeleteDuplicates /@ Transpose[idx])] =!= {d + 1} && 
     o < maxIt,
    idx = NestList[RandomSample[#, n] &, rn, d];
    ++o
    ];

   If[DeleteDuplicates[Sort /@ idx] =!= {rn},
    (* under maximal separation belongs every point to d+\
1 simplices and is the corner of at most (d+1)*d edges *) 
        Message[equiLaterator::separation, Transpose[idx]];
    ];

   If[o > 0,
    If[o >= maxIt,
     Message[equiLaterator::deflate, o];
     (* Can you do better to avoid flatness? *)
     Return[$Failed],(* else *)
     Message[equiLaterator::inflate, o];
     ]
    ];

   idxAss = 
    Counts[Sort /@ (Flatten[Subsets[#, {2}] & /@ Transpose[idx], 1])];
   If[Length[Select[idxAss, # > 1 &]] > 0,
    Message[equiLaterator::multiplicity, Select[idxAss, # > 1 &]]
    ];

   pts = RandomReal[{-cub, cub}, {n, d}];
   simplices = orientIt[pts[[#]], #] & /@ Transpose[idx];

   Print[" idx = ", simplices];

   If[! ContainsAll[ColorData["Indexed"], {colNr}],
    Message[equiLaterator::offcolor, colNr];
    colNr = Last[ColorData["Indexed"]]
    ];
   colors = 
    PadRight[ColorData[colNr, "ColorList"], n, 
     ColorData[colNr, "ColorList"]];

   aSequence[] := RandomSample[rn, n];

   equilateraLize[pts_, simplices_] := 
    Module[{pp = pts, ss = simplices, sq, o, attract = .005, p1, p2, 
      p3},
     sq = aSequence[];
     Do[{p1, p2, p3} = pp[[ss[[o]]]];
      pp[[ss[[o, 1]]]] = 
       p1 + attract (RotationTransform[\[Pi]/3, p2][p3] - p1);
      ss = orientIt[pp[[#]], #] & /@ ss, 
        {o, sq}
      ];
     {pp, ss}
     ];

   Dynamic[
    Refresh[
       If[! doneQ,
         Module[{oldPts = pts},
           {pts, simplices} = equilateraLize[pts, simplices];
           oo++;

       doneQ = oo >= maxIter || Max[Norm /@ (pts - oldPts)] < tol || 
         Max[Flatten[pts]] - Min[Flatten[pts]] > 1/tol;
          ]
        ];

     Graphics[
          {
        FaceForm[],
        MapIndexed[
            {
            EdgeForm[Directive[Thin, colors[[First[#2]]]]],
            Triangle[pts[[#1]]]
              } &,
            simplices
              ],

               MapIndexed[
            {
            PointSize[Large],
            colors[[First[#2]]],
            Point[#1]
               } &,
            pts
            ]
       },
      Epilog -> MapIndexed[
          Style[Text[First[#2], #1, labelOffset], labelStyle] &,
          pts
        ],
       Frame -> True,
      PlotRange -> All,
      PlotLabel -> Row[{"Iteration = ", oo, If[doneQ, "  (stopped)", ""]}]
      ],
     UpdateInterval -> If[doneQ, Infinity, 0.03],
     TrackedSymbols :> {}
     ]
    ]
   ] /; n >= d + 1

Against a mindless expectation only a few, if any, triangles tend to equilaterality. This might have its reason in the fact, that with random selection some edges belong to more than one triangle. But, n points should generate n triangles as ordered, (for n = 3 its the one and only triangle and it becomes equilateral soon) and n triangles need 3 n edges while n points can generate Binomial[n,2] different edges. So its only for n = 2,3,4 impossible:

In[47]:= Select[Table[{n,Binomial[n,2]},{n,3,153}],(#[[2]]<3 #[[1]])&]
Out[47]= {{3,3},{4,6},{5,10},{6,15}}

Attached is a picture how it looks: the triangle {3,4,7} seems equilateral and all others turn around it until the doneQ turns False. I've to confess that the Notebook Assistant works best if one uses it to improve working code. So the code shown has been polished by the Notebook Assistant.

Attachment

Attachments:
POSTED BY: Udo Krause
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard