(************************************************************************) (* *) (* SymmetricGroup.m *) (* An extended permutation package *) (* *) (* version 2.0 *) (* Joe Christy 10/25/90 *) (* *) (************************************************************************) (* parts from the package Permutations.m *) (* Copyright 1988 Wolfram Research Inc. *) (* * version 1.0 4/10/90 * * version 1.1 * added CycleLength, CycleLengths * JPC 4/29/90 * * version 2.0 * synchronized with 2.0 Permutations.m * JPC 10/25/91 * *) (** Elementary operations on permutations **) BeginPackage["SymmetricGroup`"] PermutationQ::usage = "PermutationQ[e] yields True if e is a list representing a permutation." ToCycles::usage = "ToCycles[p] writes the permutation p as a list of cyclic permutations." FromCycles::usage = "FromCycles[{p1,p2,..}] gives the permutation that corresponds to a list of cycles." RandomPermutation::usage = "RandomPermutation[n] gives a random permutation of n elements." InversePermutation::usage = "InversePermutation[p] gives the inverse permutation of p." Extend::usage = "Extend[p,n] embeds a permutation p in the symmetric group on n letters." ProductPermutation::usage = "ProductPermutation[p1, p2] gives the permutation gotten by applying first p1 then p2. This is the product in the smallest symmetric group containing p1 and p2." Tensor::usage = "Tensor[p1, p2] gives the tensor product of p1 and p2." IdentityPermutation::usage = "IdentityPermutation[n] gives the identical permutation of n elements." CycleLength::usage = "CycleLength[p] gives the number of cycles in the ToCycles decomposition of the permutation p." CycleLengths::usage = "CycleLengths[p] gives the a list of the lengths of the cycles in the ToCycles decomposition of the permutation p." Begin["`private`"] PermutationQ[e_] := TrueQ[ Sort[e] == Range[Length[e]] ] (** ToCycles[perm_?PermutationQ] := Block[{a, t, n, l, i, len}, len = Length[perm]; a = {} ; t = Table[True, {len}]; For[i=1, i<=len, i++, If[t[[i]], For[n = perm[[i]]; l = {}, t[[n]], n = perm[[n]], t[[n]] = False; AppendTo[l, n] ]; AppendTo[a, l] ] ] ; Return[a] ] **) ToCycles[perm_List] := Take[#, Position[Rest[#], First[#]] [[1,1]]]& /@ Last[FoldList[ If[MemberQ[Flatten[#1], #2], #1, Append[#1, NestList[perm[[#]]&, #2, Length[perm]]]]&, {}, perm]] (** FromCycles[cyc_List] := Block[{list}, Scan[ FromCycles0[list, #] &, cyc, 1] ; Array[list, Length[Flatten[cyc]]] ] FromCycles0[list_, c_] := Block[{c1}, c1 = RotateRight[c,1]; Table[ list[ c1[[i]] ] = c[[i]], {i, 1, Length[c]} ] ] **) FromCycles[cyc_List] := Last /@ Sort[Transpose[Flatten /@ {RotateRight /@ cyc, cyc}]] RandomPermutation[n_Integer?Positive] := Block[{t}, t = Array[{Random[], #} &, n]; t = Sort[t]; Map[ #[[2]] &, t ] ] (** InversePermutation[p_List] := Transpose[Sort[ Transpose[{p,Range[Length[p]]}] ]] [[2]]/; PermutationQ[p] **) InversePermutation[list_List] := Map[Last, Sort[Transpose[{list, Range[Length[list]]}]]] Extend::badSize = "`` is a permutation on more than `` letters!" Extend[p_List,n_Integer] := Join[p,Range[Length[p]+1,n]] /; PermutationQ[p] && n > Length[p] Extend[p_List,n_Integer] := p /; PermutationQ[p] && n == Length[p] Extend[p_List,n_Integer] := Message[Extend::badSize, p, n] /; PermutationQ[p] && n < Length[p] ProductPermutation[p1_,p2_] := Transpose[ Sort[Transpose[{InversePermutation[p1],p2}]] ] [[2]]/; PermutationQ[p1] && PermutationQ[p2] && Length[p1] == Length[p2] ProductPermutation[p1_,p2_] := Block[{n=Max[Length[p1], Length[p2]]}, ProductPermutation[Extend[p1,n], Extend[p2,n]] ]/; PermutationQ[p1] && PermutationQ[p2] ProductPermutation[p1_, p2_, theRest__] := Block[{pp=ProductPermutation[p1,p2]}, ProductPermutation[ pp, theRest] ]/; PermutationQ[p1] && PermutationQ[p2] Tensor[p1_,p2_] := Join[p1,p2+Length[p1]] /; PermutationQ[p1] && PermutationQ[p2] IdentityPermutation[n_Integer?Positive] := Range[n] CycleLength[perm_] := Length[ToCycles[perm]] CycleLengths[perm_] := Map[Length,ToCycles[perm]] End[] EndPackage[ ] Null