# permutation as product of transpositions

How can the permutation that takes{-f, -i, i, -e} into {-e, -i, i, -f} be realised as a sequence of nearest neighbour transpositions? In this case the succession could be

{{-e, i}, {-e, -i}, {-e, -f}, {-i, -f}, {i, -f}}


The transposition operation has the following peculiarity: the transposition {-f, -i} leaves {-f, -i, i, -e} unchanged since -f and -i are already in the right order.

I'm interested in the (or a) shortest sequence of transpositions. Often there is more then one shortest sequence.

-
I can't make sense of the {-i, f} and {i, f} swaps since there is not an f element in your original list –  belisarius Sep 20 '12 at 13:15
@belisarius Thanks. I will change it to {-i, -f} and {i, -f} –  sjdh Sep 20 '12 at 15:56

Here you have a (rather inefficient) piece of code:

l = {a, b, c, d};
r = ReplaceList[Range@Length@l, {a___, x_, y_, b___} -> {a, y, x, b}];
g = Quiet@Graph[
DeleteDuplicates@(Flatten[(UndirectedEdge[x, #] & /@ Function[t, Map[t[[#]] &, r, {2}]][x])
/. x -> # & /@ Permutations@l, 1] /. UndirectedEdge[x_, x_] -> Sequence @@ {}) //.
{a___, UndirectedEdge[x_, y_], b___, UndirectedEdge[y_, x_], c___} ->
{a, UndirectedEdge[x, y], b, c}]


And now:

s = FindShortestPath[g, {a, b, c, d}, {d, b, c, a}]

(*{{a, b, c, d}, {b, a, c, d}, {b, c, a, d}, {b, c, d, a}, {b, d, c, a}, {d, b, c, a}}*)


I am sure this is the worst possible approach

Now, for finding the transpositions used

Partition[s, 2, 1] /. {{a___, b_, c_, d___}, {a___, c_, b_, d___}} -> {b, c}

(*{{a, b}, {a, c}, {a, d}, {c, d}, {b, d}}*)


Edit

Uglier but much faster

swap[l_, j_] := Sequence @@@ {l[[1 ;; j - 1]], l[[j + 1]], l[[j]], l[[j + 2 ;;]]}
w[l_] := Module[{sw, i},
For[i = 1, i < Length@l, i++,
sw = swap[l, i];
If[! MemberQ[k, UndirectedEdge[l, sw]] && ! MemberQ[k, UndirectedEdge[sw, l]],
AppendTo[k, UndirectedEdge[l, sw]]];
If[! MemberQ[t, sw], AppendTo[t, sw]; w[sw]]
];
];
l = {a, b, c, d, e};
k = {};
t = {l};
Block[{\$RecursionLimit = 1000}, w[l]];
pg = Graph@k;
s = FindShortestPath[pg, {a, b, c, d, e}, {d, b, e, c, a}]


Edit

Just boasting, a 3D plot of the permutations:

Needs["GraphUtilities"]
pg3 = GraphPlot3D@g;
coord = GraphCoordinates3D[EdgeList@g /. UndirectedEdge -> Rule];
Animate[GraphPlot3D[g, VertexCoordinateRules -> coords,
VertexRenderingFunction -> ({Sphere[#1, 0.2]} &),
EdgeRenderingFunction -> (Cylinder[#1, 0.1] &), Boxed -> False,
ViewPoint -> RotationMatrix[x, {0, 0, 1}].{1.3, -2.4, 2},
SphericalRegion -> True], {x, 0, 2 Pi, 2 Pi/20}]


-
+1 for the idea of presenting the permutation group as a graph. Never knew that it is a polyhedron. –  Thies Heidecke Sep 20 '12 at 17:46
@ThiesHeidecke if you try it with a list of length 5, you'll see how inefficient is this way of generating the group :( –  belisarius Sep 20 '12 at 17:49
yeah, also it's more difficult to make it look pleasing embedded in 2 (or 3 projected to 2) dimensions because of the higher edge count per node, but still i like the idea of this isomorphism between permutations and graphs very much! –  Thies Heidecke Sep 20 '12 at 18:08
+1 For the sheer beauty of it. –  David Carraher Sep 20 '12 at 18:16
@ThiesHeidecke see edit, please –  belisarius Sep 21 '12 at 0:16

This follows the general logic of belisarius' approach.

Code

h[from_, to_] :=
Module[{f, g, p}, p = Permutations[from, {Length[from]}];
f[list_] := Sort /@ (UndirectedEdge[list, #] & /@ (Permute[ list, Cycles[{#}]] & /@ Partition[Range[Length[list]], 2, 1]));
g = Graph[Flatten[f /@ p, 1] // DeleteDuplicates];
FindShortestPath[g, from, to]]


Usage

h[{a, b, c, d}, {d, b, c, a}]
h[{-f, -i, i, -e}, {-e, -i, i, -f}]
h[{leaves, shoots, and, eats}, {eats, shoots, and, leaves}]


{{a, b, c, d}, {a, b, d, c}, {a, d, b, c}, {d, a, b, c}, {d, b, a, c}, {d, b, c, a}}

{{-f, -i, i, -e}, {-i, -f, i, -e}, {-i, i, -f, -e}, {-i, i, -e, -f}, {-i, -e, i, -f}, {-e, -i, i, -f}}

{{leaves, shoots, and, eats}, {shoots, leaves, and, eats}, {shoots, and, leaves, eats}, {shoots, and, eats, leaves}, {shoots, eats, and, leaves}, {eats, shoots, and, leaves}}

Also, just to mix it up...

Analysis

h[from, to] finds the shortest path from one node to another. It works with lists of varying lengths (provided that from and to have the same length).

f[list] generates all the edges from the list node. For example

f[{a, b, c, d}]


f /@ Permutations[l, {Length[l]}] generates the edges for all nodes. DeleteDuplicates eliminates repeats.

What swaps were used?

FindPermutation @@@ Partition[{{-f, -i, i, -e}, {-i, -f, i, -e}, {-i, i, -f, -e}, {-i,
i, -e, -f}, {-i, -e, i, -f}, {-e, -i, i, -f}}, 2, 1]


{Cycles[{{1, 2}}], Cycles[{{2, 3}}], Cycles[{{3, 4}}], Cycles[{{2, 3}}], Cycles[{{1, 2}}]}

-
Very nice! +1 .. –  belisarius Sep 20 '12 at 21:46

Given a permutation, you can ask Wolfram|Alpha to write it as a product of transpositions. For example: "transpositions (1,2,4,3,5)"

-

Mathematica 7 does not have all the build-in for the graph based approach of belisarius. That is why I tried an other approach

Code

moveright[list_List, i_Integer, j_Integer] := Module[{},
Table[{list[[k + 1]], list[[i]]}, {k, i, j - 1}]
]

transpositions[from_List, to_List] := Module[{now = from, next , i, transp List[]},
For[i = Length[from], i > 1, i--,
next = DeleteCases[now, to[[i]]]~Append~to[[i]];
transp = Join[transp, moveright[now, Position[now, to[[i]], 1][[1, 1]], i]];
now = Drop[next, -1];
];
transp
]

transpositions[{a, b, c, d}, {a, d, c, b}]


results in a sequence of transpositions that maps {a, b, c, d} to {a, d, c, b}:

 {{c, b}, {d, b}, {d, c}}


Explanation

If we want to go from {a, b, c, d} to {a, d, c, b}, we could

1. First look at the most right element of the final sequence, b. Why not move it to the end, thus from position 2 to position 4. The intermediate state is {a, c, d, b} .
2. Next we look at the second element from the right of the final sequence, c. In the intermediate result, c is at position 2. We move it to position 3 where it must eventually be. The intermediate state is {a, d, c, b} .
3. The third element from the right is already in the right place.
4. The last element must automatically be in the right position

This is a function generates the movements:

transpositions[from_List, to_List] :=
Module[{now = from, next , i, transp},
For[i = Length[from], i > 1, i--,
next = Complement[now, {to[[i]]}]~Append~to[[i]];
Print[moveright[now, Position[now, to[[i]]][[1, 1]], i]];
now = Drop[next, -1];
]
]

transpositions[{a, b, c, d}, {a, d, c, b}]


it gives

moveright[{a,b,c,d},2,4]
moveright[{a,c,d},2,3]
moveright[{a,d},2,2]


moveright[{a,b,c,d},2,4] is to be interpreted as: move element 2 of {a,b,c,d} to position 4.

Notice that the intermediate steps become shorter at each step. The last elements of the intermediate step are already in final position, and no other element will be moved to the right of them. They will not participate in any movement any more, so they can be dropped.

At last we need a way to move elements to the right. The only operation avaiable is to swapping two neibouring elments.

moveright[list_List, i_Integer, j_Integer] := Module[{},
Table[{list[[k + 1]], list[[i]]}, {k, i, j - 1}]
]
moveright[{a, b, c, d}, 2, 4]


results in a sequence of two transpositions that bring '{a, b, c, d}' to '{a, c, d, b}'

{{c, b}, {d, b}}
`
-