Riffling Cards in Mathematica

Question

My friend posed this question to me; felt like sharing it here.

Given a deck of cards, we split it into 2 groups, and "interleave them"; let us call this operation a 'split-join'. And repeat the same operation on the resulting deck.

E.g., { 1, 2, 3, 4 } becomes { 1, 2 } & { 3, 4 } (split) and we get { 1, 3, 2, 4 } (join)

Also, if we have an odd number of cards i.e., { 1, 2, 3 } we can split it like { 1, 2 } & { 3 } (bigger-half first) leading to { 1, 3, 2 } (i.e., n is split up as Ceil[n/2] & n-Ceil[n/2])

The question my friend asked me was:

HOW many such split-joins are needed to get the original deck back?

And that got me wondering:

If the deck has n cards, what is the number of split-joins needed if:

• n is even ?
• n is odd ?
• n is a power of '2' ? [I found that we then need log (n) (base 2) number of split-joins...]
• (Feel free to explore different scenarios like that.)

Is there a simple pattern/formula/concept correlating n and the number of split-joins required?

I believe, this is a good thing to explore in Mathematica, especially, since it provides the Riffle[] method.

Answer 1

old question I know, but strange no one put up an actual mathematica solution..

 countrifflecards[deck_] := Module[{n = Length@deck, ct, rifdeck},
      ct = 0;
      rifdeck = 
        Riffle @@ 
          Partition[ # , Ceiling[ n/2], Ceiling[ n/2], {1, 1}, {} ] &;
      NestWhile[(++ct; rifdeck[#]) &, deck, #2 != deck &,2 ]; ct]

This handles even and odd cases:

 countrifflecards[RandomSample[ Range[#], #]] & /@ Range[2, 52, 2]

{1, 2, 4, 3, 6, 10, 12, 4, 8, 18, 6, 11, 20, 18, 28, 5, 10, 12, 36, 12, 20, 14, 12, 23, 21, 8}

 countrifflecards[RandomSample[ Range[#], #]] & /@ Range[3, 53, 2]

{2, 4, 3, 6, 10, 12, 4, 8, 18, 6, 11, 20, 18, 28, 5, 10, 12, 36, 12, 20, 14, 12, 23, 21, 8, 52}

You can readily show if you add a card to the odd-case the extra card will stay on the bottom and not change the sequence, hence the odd case result is just the n+1 even result..

 ListPlot[{#, countrifflecards[RandomSample[ Range[#], #]]} & /@ 
      Range[2, 1000]]