10
$\begingroup$

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

Hanoi-2

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.

$\endgroup$
11
$\begingroup$

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]

Hanoi graph, n=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

states

| improve this answer | |
$\endgroup$
  • 2
    $\begingroup$ Nicely done...+1. $\endgroup$ – Anjan Kumar Dec 2 '17 at 17:16

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.