Pancake Sorting

Author

Eric W. Weisstein
September 4, 2006

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputerScience/PancakeSorting.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/PancakeSorting.html.

©2006 Wolfram Research, Inc. except for portions noted otherwise

Comments

The code below should be rewritten to use backtracking, caching, or any method that is reasonably efficient

Pancake Graphics

Pancakes[l_List]:=Module[{dz=.15,h=.05},
Graphics[Table[{
{Yellow,Disk[{0,-i dz},{1,h}]},
Circle[{0,-i dz},{1,h}],
Text[ToString[l[[i]]],{0,-i dz}]
},{i,Length[l]}]
]
]

Show[Pancakes[{1,2,3}]]

Calculate the pancake ordering after a flip sequence

Flip[n_Integer,l_List]:=Flip[Range[n],l]

Flip[p0_List,l_List?VectorQ]:=Module[{i,n=Length[p0],p=p0},
Do[p=Join[Reverse[Take[p,l[[i]]]],Take[p,{l[[i]]+1,n}]],
{i,Length[l]}];
p
]

Flip[p_List,m_List?MatrixQ]:=Flip[p,#]&/@m

FlipList[l_,f_]:=FoldList[Flip,l,List/@f]

Examples

Flip[5,{2}]

Flip[5,{2,5}]

Flip[5,{5}]

Calculate all unique flip sequences of a given length

flips[1,max_]:=List/@Range[2,max]
flips[len_,max_]:=Select[Flatten[Outer[List,Sequence@@Table[Range[2,max],{len}]],len-1],Length[Split[#]]>1&]

flips[1,4]

flips[2,3]

Calculate the minimum number of flips to order a given stack

MinFlips[l_List]:=Module[{n=1,p,f,o=Range[Length[l]],max=Length[l]},
While[!MemberQ[p=Flip[l,f=flips[n,max]],o],
(*Print[n];*)
n++
];
{n,l,f[[Position[p,o,1,1][[1]]]][[1]]}
]

MinFlips[{1,3,2}]

MinFlips[#]&/@Rest[Permutations[Range@2]]

MinFlips[#]&/@Rest[Permutations[Range@3]]

Maximum number of flips needed for stacks of n pancakes

<<DiscreteMath`Combinatorica`

Triangle

Prepend[#,1]&/@Table[Length/@Split[Sort[First/@(MinFlips[#]&/@Rest[Permutations[n]])]],{n,6}]//Timing

tri={{1},{1,1},{1,2,2,1},{1,3,6,11,3},{1,4,12,35,48,20},{1,5,20,79,199,281,133,2},{1,6,30,149,543,1357,1903,1016,35},{1,7,42,251,1191,4281,10561,15011,8520,455},{1,8,56,391,2278,10666,38015,93585,132697,79379,5804},{1,9,72,575,3963,22825,106461,377863,919365,1309756,814678,73232},{1,10,90,809,6429,43891,252737,1174766,4126515,9981073,14250471,9123648,956354,6},{1,11,110,1099,9883,77937,533397,3064788,14141929,49337252,118420043,169332213,111050066,13032704,167}};

Length/@tri-1 (* Sloane's A058986 *)

Last/@tri (* Sloane's A067607 *)

Plus@@@tri-Table[n!,{n,Length[tri]}]

Plot

<<Utilities`Plot`

Show[PixelPerfect[NaryPlot[Flatten[tri]],BlockSize->4]]

ColorInterior[l_]:=Module[{n=1+Length[l]-Position[Reverse[l],1,1,1][[1,1]]},
Join[Take[l,n],Take[l,n-Length[l]]/. 0->-1]
]

ArrayPlot[Transpose[Reverse/@ColorInterior/@Reverse/@Transpose[NaryPlot[Flatten[tri]]]],Frame->False,PixelConstrained->True,ImageSize->400,ColorRules->{-1->White,0->Green,1->Black}]

1

0

2

Max[First/@(MinFlips[#]&/@Rest[Permutations[2]])]

Select[MinFlips[#]&/@Rest[Permutations[2]],First[#]==1&]

3

Max[First/@(MinFlips[#]&/@Rest[Permutations[3]])]

Select[MinFlips[#]&/@Rest[Permutations[3]],First[#]==3&]

Length[%]

4

Max[First/@(MinFlips[#]&/@Rest[Permutations[4]])]

Select[MinFlips[#]&/@Rest[Permutations[4]],First[#]==4&]

Length[%]

p={{4,{2,4,1,3},{2,4,3,2}},{4,{3,1,4,2},{2,3,4,2}},{4,{4,2,3,1},{2,3,2,4}}};

Show[GraphicsArray[Pancakes/@FlipList[{2,4,1,3},{2,4,3,2}]]]

Show[GraphicsArray[Pancakes/@FlipList[#1,#2]&@@@(Rest/@p)]]

5

Max[First/@(l=MinFlips[#]&/@Rest[Permutations[5]])]//Timing

Select[l,First[#]==5&]

Length[%]

6

Max[First/@(l=MinFlips[#]&/@Rest[Permutations[Range@6]])]//Timing

Length/@Split[Sort[First/@l]]

p=Select[l,First[#]==7&]

Show[GraphicsArray[Pancakes/@FlipList[#1,#2]&@@@(Rest/@p)]]

7

Maximum number of flips needed

Max[First/@(l=MinFlips[#]&/@Rest[Permutations[Range@7]])]//Timing

Numbers of stacks requiring k flips

Length/@Split[Sort[First/@l]]

Stacks requiring a maximal (=8) number of flips to sort

Select[l,First[#]==8&]

11

MinFlips[{10,6,3, 8, 5, 2, 7, 4, 9, 1, 11}]//Timing

12

MinFlips[{11,6,8,10,5,2,7,3,9,4,1,12}]//Timing