permutation as product of transpositions

Question

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.

Answer 1

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];
Thread[VertexList[g] -> coord];
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}]

Answer 2

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

Answer 3

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

Answer 4

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