Permutations distinct under given symmetry (Mathematica 8 group theory)

696 Views Asked by At

Given a list of integers like {2,1,1,0} I'd like to list all permutations of that list that are not equivalent under given group. For instance, using symmetry of the square, the result would be {{2, 1, 1, 0}, {2, 1, 0, 1}}.

Approach below (Mathematica 8) generates all permutations, then weeds out the equivalent ones. I can't use it because I can't afford to generate all permutations, is there a more efficient way?

Update: actually, the bottleneck is in DeleteCases. The following list {2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 0, 0, 0} has about a million permutations and takes 0.1 seconds to compute. Apparently there are supposed to be 1292 orderings after removing symmetries, but my approach doesn't finish in 10 minutes

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}]
2

There are 2 best solutions below

0
On BEST ANSWER

I got an elegant and fast solution from Maxim Rytin, relying on ConnectedComponents function

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
5
On

What's wrong with:

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

I don't have Mathematica 8, so I can't test this. I just have Mathematica 7.