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.
