# Hanoi Tower minimum moves between any two states

Goal:

I want to make some gifs which show minimum moves between two states.

All the avaliable states can be written as a graph, Hanoi Graph, GraphData[{"Hanoi",n}].

The minimum moves between two states equivalent to the shortest path between two vertexs.

But I can not find a suitable mapping between states and vertex numbers.

Meanwhile GraphData only works when $n<6$, and I think graph algorithm maybe slow.

Encoding:

A list like {{1,2,3},{4,5},{6}} means three disks on the rod $A$, the radii from top to bottom are $1\ 2\ 3$ in order.

Input:

start={{1,4},{2,8},{5,7}};
finish={{2,8},{5,7},{1,4}};
HanoiMove[start,finish]//Length
(* use length as a check *)


Output:

Transfer rules {1->A,2->B...} or states lists {step1,step2...} or animation are all acceptable.

We start with a better abc encoding (the one shown on your graph picture). State aabcac means: on first rod (rod a), there are rings 1, 2, and 5; on the second rod b, only ring 3; on the rod c, rings 4 and 6.

In[1]:= NumberListToABC[{A_, B_, C_}] := Table[Piecewise[{
{a, MemberQ[A, i]}, {b, MemberQ[B, i]}, {c, True}}], {i, Max[A, B, C]}];
ABCToNumberList[abc_] := Flatten[Position[abc, #]] & /@ {a, b, c};

In[2]:= NumberListToABC[{{1, 2, 5}, {3}, {4, 6}}]

Out[2]= {a, a, b, c, a, c}

In[3]:= ABCToNumberList[{a, a, b, c, a, c}]

Out[3]= {{1, 2, 5}, {3}, {4, 6}}


Now we want to be able to generate Hanoi graph ourselves. The simplest way is to use recursion. When we got all states with 5 rings, we can add a 6th (new largest) ring on the bottom of each rod (copying the graph 3 times). But we can move it between two rods (say a and b) only when all other rings are on the third rod c (add 3 new edges connecting these graph copies).

In[4]:= AddNewRing[ops_, rod_] := Map[Append[#, rod] &, ops, {2}];
LargestRingMove[n_, {a_, b_, c_}] :=
Append[Table[a, {n}], b] <-> Append[Table[a, {n}], c]
Step[ops_] := Module[{n = If[ops == {}, 0, Length@ops[[1, 1]]]},
Flatten@{AddNewRing[ops, #] & /@ {a, b, c},
LargestRingMove[n, RotateLeft[{a, b, c}, #]] & /@ Range[3]}];
HanoiGraph[n_] := Graph@Nest[Step, {}, n];

In[5]:= g = HanoiGraph[6]


The rest is pretty straightforward.

In[6]:= start = {{1, 2}, {4, 6}, {3, 5}};
finish = {{2, 6}, {3, 5}, {1, 4}};
{s1, s2} = NumberListToABC /@ {start, finish};
path = FindShortestPath[g, s1, s2];
states = ABCToNumberList /@ path

Out[6]= {{{1, 2}, {4, 6}, {3, 5}}, {{2}, {4, 6}, {1, 3, 5}}, {{}, {2, 4,
6}, {1, 3, 5}}, {{}, {1, 2, 4, 6}, {3, 5}}, {{3}, {1, 2, 4,
6}, {5}}, {{3}, {2, 4, 6}, {1, 5}}, {{2, 3}, {4, 6}, {1, 5}}, {{1,
2, 3}, {4, 6}, {5}}, {{1, 2, 3}, {6}, {4, 5}}, {{2, 3}, {6}, {1, 4,
5}}, {{3}, {2, 6}, {1, 4, 5}}, {{3}, {1, 2, 6}, {4, 5}}, {{}, {1,
2, 6}, {3, 4, 5}}, {{1}, {2, 6}, {3, 4, 5}}, {{1}, {6}, {2, 3, 4,
5}}, {{}, {6}, {1, 2, 3, 4, 5}}, {{6}, {}, {1, 2, 3, 4,
5}}, {{6}, {1}, {2, 3, 4, 5}}, {{2, 6}, {1}, {3, 4, 5}}, {{1, 2,
6}, {}, {3, 4, 5}}, {{1, 2, 6}, {3}, {4, 5}}, {{2, 6}, {3}, {1, 4,
5}}, {{6}, {2, 3}, {1, 4, 5}}, {{6}, {1, 2, 3}, {4, 5}}, {{4,
6}, {1, 2, 3}, {5}}, {{1, 4, 6}, {2, 3}, {5}}, {{1, 4, 6}, {3}, {2,
5}}, {{4, 6}, {3}, {1, 2, 5}}, {{3, 4, 6}, {}, {1, 2, 5}}, {{3, 4,
6}, {1}, {2, 5}}, {{2, 3, 4, 6}, {1}, {5}}, {{1, 2, 3, 4,
6}, {}, {5}}, {{1, 2, 3, 4, 6}, {5}, {}}, {{2, 3, 4, 6}, {1,
5}, {}}, {{3, 4, 6}, {1, 5}, {2}}, {{3, 4, 6}, {5}, {1, 2}}, {{4,
6}, {3, 5}, {1, 2}}, {{1, 4, 6}, {3, 5}, {2}}, {{1, 4, 6}, {2, 3,
5}, {}}, {{4, 6}, {1, 2, 3, 5}, {}}, {{6}, {1, 2, 3,
5}, {4}}, {{6}, {2, 3, 5}, {1, 4}}, {{2, 6}, {3, 5}, {1, 4}}}


Finally, to make things nicer, we can illustrate the process:

In[7]:= d = 0.5;
cmap = ColorData[97, "ColorList"];
DrawRod[list_, x0_, l_] := Module[{n = Length@list},
{White, Line[{{x0 - l, 0}, {x0 + l, 0}}],
Riffle[cmap[[list]], Rectangle[{x0 - list[[#]], (n - #) d},
{x0 + list[[#]], d (n - # + 1)}] & /@ Range@Length@list]}];
DrawState[{A_, B_, C_}] := Module[{n = Max[A, B, C]},
Graphics[{DrawRod[A, -2.1 n, n], DrawRod[B, 0, n], DrawRod[C, 2.1 n, n]}]];
DrawState /@ states // MatrixForm


• Nicely done...+1. – Anjan Kumar Dec 2 '17 at 17:16