Answer update, 12/22: Using Peter Shor's observation that there's a homomorphism between distinct sections and permutations of objects on the cube, list all such permutations by representing a group of cube symmetries as a subgroup of SymmetricGroup[8] and using GroupElements/Permute, find centroid assignments using Mathematica's SAT solver, select point sets with distinct singular values, few more details and complete code given here
Question
An interesting 2D section is a plane that goes through the center of a regular 3D simplex and 2 other points each of which is a centroid of some non-empty subset of vertices. It is defined by two subsets of vertices. For instance {{1},{1,2}} gives a plane defined by 3 points -- center of the tetrahedron, first vertex, and average of first and second vertices.
An interesting set of sections is a set in which no two sections define the same plane under vertex relabeling. For instance, set {{{1},{2}},{{3},{4}}} is not interesting. Is there an efficient approach to finding an interesting set of interesting sections? I need something that could generalize to an analogous problem for 3D sections of 7D simplex, and finish overnight.
My attempted approach is below. One problem is that if you ignore geometry, some equivalent sections are going to be retained, so I get 10 sections instead of 3. A bigger problem is that I used brute-force and it definitely doesn't scale and (needs 10^17 comparisons for 7D simplex)
(source: yaroslavvb.com)
Here's the Mathematica code to generate picture above.
entropy[vec_] := Total[Table[p Log[p], {p, vec}]];
hadamard = KroneckerProduct @@ Table[{{1, 1}, {1, -1}}, {2}];
(* rows of hadamard matrix give simplex vertex coordinates *)
vertices = hadamard;
invHad = Inverse[hadamard];
m = {m1, m2, m3, m4};
vs = Range[4];
(* take a set of vertex averages, generate all combinations arising \
from labeling of vertices *)
vertexPermutations[set_] := (
newSets = set /. Thread[vs -> #] & /@ Permutations[vs];
Map[Sort, newSets, {2}]
);
(* anchors used to define a section plane *)
sectionAnchors = Subsets[{1, 2, 3, 4}, {1, 3}];
(* all sets of anchor combinations with centroid anchor always \
included *)
anchorSets = Subsets[sectionAnchors, {2}];
anchorSets = Prepend[#, {1, 2, 3, 4}] & /@ anchorSets;
anchorSets = Map[Sort, anchorSets, {2}];
setEquivalent[set1_, set2_] := MemberQ[vertexPermutations[set1], set2];
equivalenceMatrix =
Table[Boole[setEquivalent[set1, set2]], {set1, anchorSets}, {set2,
anchorSets}];
Needs["GraphUtilities`"];
(* Representatives of "vertex-relabeling" equivalence classes of \
ancher sets *)
reps = First /@ StrongComponents[equivalenceMatrix];
average[verts_] := Total[vertices[[#]] & /@ verts]/Length[verts];
makeSection2D[vars_, {p0_, p1_, p2_}] := Module[{},
v1 = p1 - p0 // Normalize;
v2 = p2 - p0;
v2 = v2 - (v1.v2) v1 // Normalize;
Thread[vars -> (p0 + v1 x + v2 y)]
];
plotSection2D[f_, pointset_] := (
simplex =
Graphics3D[{Yellow, Opacity[.2],
GraphicsComplex[Transpose@Rest@hadamard,
Polygon[Subsets[{1, 2, 3, 4}, {3}]]]}];
anchors = average /@ pointset;
section = makeSection2D[m, anchors];
rf = Function @@ ({{x, y, z, u, v},
And @@ Thread[invHad.{1, x, y, z} > 0]});
mf = Function @@ {{p1, p2, p3, x, y}, f[invHad.m /. section]};
sectionPlot =
ParametricPlot3D @@ {Rest[m] /. section, {x, -3, 3}, {y, -3, 3},
RegionFunction -> rf, MeshFunctions -> {mf}};
anchorPlot = Graphics3D[Sphere[Rest[#], .05] & /@ anchors];
Show[simplex, sectionPlot, anchorPlot]
);
plots = Table[
plotSection2D[entropy, anchorSets[[rep]]], {rep, reps}];
GraphicsGrid[Partition[plots, 3]]