列出四面体的所有有趣部分
答案更新，12/22： 使用 Peter Shor 的观察，存在同态在立方体上的不同部分和对象排列之间，通过将一组立方体对称性表示为 SymmetricGroup[8] 的子群并使用 GroupElements/Permute 列出所有此类排列，使用 Mathematica 的 SAT 求解器查找质心分配，选择具有不同奇异值的点集值，更多细节和完整代码此处给出
问题
一个有趣的 2D 截面是一个穿过常规 3D 中心的平面 simplex 和其他 2 个点，每个点都是某些非空顶点子集的质心。它由两个顶点子集定义。例如，{{1},{1,2}} 给出由 3 个点定义的平面：四面体中心、第一个顶点以及第一个和第二个顶点的平均值。
一组有趣的部分是其中没有两个部分在顶点重新标记下定义同一平面的集合。例如，集合 {{{1},{2}},{{3},{4}}} 并不有趣。有没有一种有效的方法来找到一组有趣的有趣部分？我需要一些可以推广到 7D 单纯形的 3D 部分的类似问题的东西，并且可以在一夜之间完成。
我尝试的方法如下。一个问题是，如果你忽略几何图形，一些等效的部分将被保留，所以我得到 10 个部分而不是 3 个。一个更大的问题是我使用了蛮力，它肯定无法缩放并且（需要 10^17 7D 单纯形比较)
（来源：yaroslavvb.com）
这是Mathematica 代码来生成上面的图片。
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]]
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]]
如果你对这篇内容有疑问，欢迎到本站社区发帖提问 参与讨论，获取更多帮助，或者扫码二维码加入 Web 技术交流群。
绑定邮箱获取回复消息
由于您还没有绑定你的真实邮箱，如果其他用户或者作者回复了您的评论，将不能在第一时间通知您！
发布评论
评论（1）
概括地说，正确的编程解决方案是：
四面体在顶点标签排列下是完全对称的。因此，任何“有趣的部分”等价于仅包含顶点的前导部分的另一个部分 - 即可以在某些 n 的顶点 Range[1,n] 之间进行识别。
收集以上内容，我们发现存在从有趣部分到一组图的满射。对于每个图，我们必须枚举一致的顶点成员资格（稍后描述）。除一个顶点外，图的顶点都是成对的
在具有四个顶点的三个维度的情况下，我们得到以下集合（我们使用短投影对，因为此示例中有足够的可见性，不需要更简单的顶点标记拒绝规则）：
0：射影对 {1,2,3,4}
1：{1}
1'：{2}，{3}，{4}
2：{1,2}，{1,3}，{1,4}
2'：投影对 2（因此省略）
3：到 1' 的投影对（因此省略）
3'：射影对 1（因此省略）
标签约束：
{0->x,x}
{0->x',x}
{1->1,1} -- 不允许：中心不包含两次
{1->1',0}
{1->2,1}
{2->2,1}
这些图顶点不可能有其他权重。
图是 0 上的 K_{3} 事件，以下图符合图选择规则：
答：{0->1,1},{0->1',1},{1->1',0}
B：{0->2,2}、{0->2,2}、{2->2,1}
A 只有一个标签：{1}、{2}、{}，并且是您的有趣的三角形集。该标签不具有零行列式。
B 只有一个标签：{1,2}、{1,3}、{}，并且是您的方形有趣集合。该标记不具有零行列式。
转换为代码作为练习留给读者（因为我必须去上班）。
The correct programming solution is, in outline:
Tetrahedra are completely symmetric under permutation of vertex labels. Consequently, any "interesting section" is equivalent to another section containing only the leading segment of vertices -- i.e. can be identified among the vertices Range[1,n] for some n.
Collecting the above, we find that there is a surjection from interesting section to a set of graphs. For each graph we must enumerate consistent vertex memberships (described later). Except for one vertex, the vertices of the graph come in pairs
In the case of three dimensions, with four vertices, we get the following sets (we use the short projective pair because there's enough visibility in this example to not necessitate the simpler vertex labeling rejection rule):
0: projective pair of {1,2,3,4}
1: {1}
1': {2},{3},{4}
2: {1,2},{1,3},{1,4}
2': projective pairs to 2 (so omitted)
3: projective pairs to 1' (so omitted)
3': projective pairs to 1 (so omitted)
Label constraints:
{0->x,x}
{0->x',x}
{1->1,1} -- disallowed: centers are not included twice
{1->1',0}
{1->2,1}
{2->2,1}
No other weights are possible with these graph vertices.
A graph is a K_{3} incident on 0, the following graphs survive the graph selection rules:
A: {0->1,1},{0->1',1},{1->1',0}
B: {0->2,2},{0->2,2},{2->2,1}
A has only one labeling: {1},{2},{} and is your triangular interesting set. This labeling does not have zero determinant.
B has only one labeling: {1,2},{1,3},{} and is your square interesting set. This labeling does not have zero determinant.
Converting to code is left as an exercise to the reader (because I have to leave for work).