Re: Counting
- To: mathgroup at smc.vnet.net
- Subject: [mg114978] Re: Counting
- From: Leonid Shifrin <lshifr at gmail.com>
- Date: Sat, 25 Dec 2010 02:34:40 -0500 (EST)
- References: <201012200540.AAA22760@smc.vnet.net>
Hi Yaroslav,
this is a follow - up to my previous post. I think that the code I just
posted grossly overestimates
the number of non-equivalent permutations, because I forgot about the
non-abelian nature of
permutations and my method explores only a part of the group space. I did
not figure out the
rigorous way to solve this problem (perhaps one should look more carefully
at the group structure),
but we can at least modify the code to give an upper bound on the number of
non-equivalent
permutations:
1. Modify the code for getUniquePermutatations, to apply the longest cycles
first
Clear[getUniquePermutatationsAlt];
getUniquePermutatationsAlt[permutations_, actions : {__Cycles}] /;
Length[permutations] > 0 :=
With[{rlen = Range[Length[permutations[[1]]]]},
Fold[reducePermutationsC, permutations,
Map[Permute[rlen, #] &, SortBy[actions, Length@#[[1]] &]]]]
2. Use this function inside FixedPoint:
In[80]:= FixedPoint[ getUniquePermutatationsAlt[#,actions]&,perms]//Timin=
g
Out[80]=
{5.016,{{0,0,0,0,0,0,0,2,1,2,2,2,2,1,2,2},{0,0,0,0,0,0,0,2,1,2,2,2,1,2,2,2}=
,{0,0,0,0,0,0,0,2,1,2,2,1,2,2,2,2},{0,0,0,0,0,0,0,2,1,2,1,2,2,2,2,2},{0,0,0=
,0,0,0,0,2,1,1,2,2,2,2,2,2},{0,0,0,0,0,0,0,1,2,2,2,2,2,2,2,1},{0,0,0,0,0,0,=
0,1,2,2,2,2,2,2,1,2},{0,0,0,0,0,0,0,1,2,2,2,2,2,1,2,2},{0,0,0,0,0,0,0,1,2,2=
,2,2,1,2,2,2},{0,0,0,0,0,0,0,1,2,2,2,1,2,2,2,2},{0,0,0,0,0,0,0,1,2,2,1,2,2,=
2,2,2},{0,0,0,0,0,0,0,1,2,1,2,2,2,2,2,2},{0,0,0,0,0,0,0,1,1,2,2,2,2,2,2,2}}=
}
I don't have a proof with this method that none of the above is really
equivalent to others, alas. I have
some (empirical) evidence that this may be the case, but obviously better
arguments are needed here.
That is, if I understood the problem at all correctly, which is something =
I
am also starting to doubt.
Regards,
Leonid
On Mon, Dec 20, 2010 at 8:40 AM, Yaroslav Bulatov <yaroslavvb at gmail.com>wro=
te:
> I'd like to count the number of permutations of {2, 2, 2, 2, 2, 2, 2,
> 1, 1, 0, 0, 0, 0, 0, 0, 0} that are not equivalent under the symmetry
> of DihedralGroup[16]. In other words, count the ways of assigning
> those integers to vertices of a 4 dimensional cube.
>
> This takes about a minute in another systme using "OrbitsDomain" command.
> My
> Mathematica approach is below, however it doesn't finish within 10
> minutes, any advice how to make it tractable?
>
> nonequivalentPermutations[lst_, group_] := (
> removeEquivalent[{}] := {};
> removeEquivalent[list_] := (
> Sow[First[list]];
> equivalents = Permute[First[list], #] & /@ GroupElements[group];
> DeleteCases[list, Alternatives @@ equivalents]
> );
>
> reaped = Reap@FixedPoint[removeEquivalent, Permutations@lst];
> reaped[[2, 1]] // Length
> );
> nonequivalentPermutations[{2, 2, 2, 2, 2, 2, 2, 1, 1, 0, 0, 0, 0, 0,
> 0, 0}, DihedralGroup[16]]
>
>
- References:
- Counting
- From: Yaroslav Bulatov <yaroslavvb@gmail.com>
- Counting