Task: Find a permutation of the numbers 1 through n, such that if a deck of n cards is prepared in this order, and down-under-down dealing is used, then the resulting cards will be dealt in increasing order. (OEIS A381050: Down-under-down shuffle)

Convention in visualization

Say we have 6 cards. When we say the cards are in increasing order, we mean that the top card is 1(A) and the card at the bottom is 6.
In[]:=
init=Range[6]
Out[]=
{1,2,3,4,5,6}
In[]:=
deck=
[◼]
PlayingCardGraphic
[Reverse@init,"CardSpreadAngle"->0.3]
Out[]=

Card preparation

By pre-shuffling the cards in this manner, we ensure that the cards will be sorted correctly after performing the down-under-down shuffle repeatedly:
In[]:=
row[n_]:=Module[{ds,res,k,i=1,len},ds=CreateDataStructure["Queue",Range[n]];res=CreateDataStructure["FixedArray",n];While[(ds["Length"]>=2),res["SetPart",i++,ds["Pop"]];ds["Push",ds["Pop"]];If[ds["Length"]>1,res["SetPart",i++,ds["Pop"]];]];res["SetPart",n,ds["Pop"]];Flatten[PositionIndex[res["Elements"]]/@Range[n]]];
The concept is to start with an ordered deck and then perform the shuffle as specified in the task. The permutation cycle of the newly shuffled deck represents the inverse permutation of the solution we aim to find.
For instance, we start with 6 cards ordered {1,2,3,4,5,6}. After Down-under-down shuffle repeatedly we rearrange the deck to {1,3,4,6,2,5}
In[]:=
cyc=InversePermutation@FindPermutation[{1,3,4,6,2,5}]
Out[]=
Cycles[{{2,3,4,6,5}}]
In[]:=
row[6]
Out[]=
{1,5,2,3,6,4}
In[]:=
Permute[{1,2,3,4,5,6},cyc]
Out[]=
{1,5,2,3,6,4}

Define the step by step operation and display function

This function leverages a pair of decks as both input and output to capitalize on the functional programming paradigm:
In[]:=
Clear[dud]
In[]:=
dud[deck_List,nthStep_Integer]:=Module[{d1,d2},​​d1=deck[[1]];​​d2=deck[[2]];​​If[(Mod[nthStep,3]==1||Mod[nthStep,3]==0)||Length[d1]==1,​​d2=Append[d2,d1[[1]]];​​d1=Rest[d1]​​,​​d1=Append[Rest@d1,d1[[1]]]];{d1,d2}]
The display function uses the WFR “PlayingCardGraphic” item. I add a feature here to handle empty list with empty graphics:
In[]:=
deckDisplayFunc[status_List]:=​​LabeledGraphicsRowIf#!={},Rasterize@
[◼]
PlayingCardGraphic
[Reverse@#,"CardSpreadAngle"->0.3,ImageSize->{220,250}],Rasterize@Graphics[{},ImageSize->{220,250}]&/@status[[;;2]],Style[status[[3]],18]

Simulation with a deck of 8 cards

Prepare the deck:
In[]:=
dudInit={row[8],{}};
In[]:=
steps=FoldWhileList[dud,dudInit,Range[10000],(#[[1]]!={})&];​​stepsWithID=MapIndexed[Append[#,#2[[1]]]&,steps];
In[]:=
Grid[stepsWithID,Alignment->Left]
Out[]=
{1,6,2,3,7,4,5,8}
{}
1
{6,2,3,7,4,5,8}
{1}
2
{2,3,7,4,5,8,6}
{1}
3
{3,7,4,5,8,6}
{1,2}
4
{7,4,5,8,6}
{1,2,3}
5
{4,5,8,6,7}
{1,2,3}
6
{5,8,6,7}
{1,2,3,4}
7
{8,6,7}
{1,2,3,4,5}
8
{6,7,8}
{1,2,3,4,5}
9
{7,8}
{1,2,3,4,5,6}
10
{8}
{1,2,3,4,5,6,7}
11
{}
{1,2,3,4,5,6,7,8}
12
Beautifully display the steps in grid. Steps are ordered in zig-zag pattern and left first:
In[]:=
GraphicsGrid[Partition[deckDisplayFunc/@stepsWithID,3],Dividers->All]

CITE THIS NOTEBOOK

OEIS A381050: down-under-down shuffle with steps​
by Shenghui Yang​
Wolfram Community, STAFF PICKS, May 20, 2025
​https://community.wolfram.com/groups/-/m/t/3464417