Question

给定一个像{2,1,1,0}这样的整数列表，我想列出该列表中在给定组下不等效的所有排列。例如，使用symmetry of the square，结果将是{{2, 1, 1, 0}, {2, 1, 0, 1}}。

下面的方法（Mathematica 8）生成所有排列，然后清除相应的排列。我无法使用它，因为我无法承担所有排列，是否有更有效的方法？

更新：实际上，瓶颈在DeleteCases。以下列表{2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 0, 0, 0}有大约一百万个排列，计算时间为0.1秒。显然在删除对称性后应该有1292个排序，但我的方法在10分钟内没有完成

removeEquivalent[{}] := {};
removeEquivalent[list_] := (
   Sow[First[list]];
   equivalents = Permute[First[list], #] & /@ GroupElements[group];
   DeleteCases[list, Alternatives @@ equivalents]
   );
nonequivalentPermutations[list_] := (
   reaped = Reap@FixedPoint[removeEquivalent, Permutations@list];
   reaped[[2, 1]]
   );

group = DihedralGroup[4];
nonequivalentPermutations[{2, 1, 1, 0}]

Answer 1

出了什么问题：

nonequivalentPermutations[list_,group_]:= Union[Permute[list,#]& /@ GroupElements[group];
nonequivalentPermutations[{2,1,1,0},DihedralGroup[4]]

我没有Mathematica 8，所以我无法测试。我只有Mathematica 7。

Answer 2

我从Maxim Rytin那里得到了一个优雅而快速的解决方案，依靠ConnectedComponents功能

Module[{gens, verts, edges},
 gens = PermutationList /@ GroupGenerators@DihedralGroup[16];
 verts =
  Permutations@{2, 2, 2, 2, 2, 2, 2, 1, 1, 0, 0, 0, 0, 0, 0, 0};
 edges = Join @@ (Transpose@{verts, verts[[All, #]]} &) /@ gens;
 Length@ConnectedComponents@Graph[Rule @@@ Union@edges]] // Timing

给定对称性下的排列不同（Mathematica 8群论）

2 个答案: