The "perfect shuffles" puzzle (solved in Haskell)

Tom Moertel — Thu, 23 Mar 2006 16:51:00 -0500

I ran across a fun programming puzzle (via Raganwald):

Given a deck of n unique cards, cut the deck i cards from top and perform a perfect shuffle. A perfect shuffle begins by putting down the bottom card from the top portion of the deck followed by the bottom card from the bottom portion of the deck followed by the next card from the top portion, etc., alternating cards until one portion is used up. The remaining cards go on top. The problem is to find the number of perfect shuffles required to return the deck to its original order. Your function should be declared as:

static long shuffles(int nCards,int iCut);

Please send the result of shuffles(1002,101) along with your program and your resume to ‘resume’ at nextag.com.

It’s a fun problem, so give it a try before reading on.

Warning: small spoilers ahead

The first thing I usually do when I encounter a new problem is explore it until I have a feel for its essence. For this problem, the shuffle algorithm seemed like a good starting point:

shuffle n i =
    reverse . uncurry (flip interleave) . splitAt (n-i) . reverse

interleave (x:xs) (y:ys) = x : y : interleave xs ys
interleave xs     []     = xs
interleave []     ys     = ys

From within GHCi, I watched a few iterations, using a ten-card deck as input:

*Main> mapM_ print . take 10 $ iterate (shuffle 10 3) [0..9]
[0,1,2,3,4,5,6,7,8,9]
[3,4,5,6,7,0,8,1,9,2]
[6,7,0,8,1,3,9,4,2,5]
[8,1,3,9,4,6,2,7,5,0]
[9,4,6,2,7,8,5,1,0,3]
[2,7,8,5,1,9,0,4,3,6]
[5,1,9,0,4,2,3,7,6,8]
[0,4,2,3,7,5,6,1,8,9]
[3,7,5,6,1,0,8,4,9,2]
[6,1,0,8,4,3,9,7,2,5]

After a bit of study, a light-bulb appeared over my head, and I realized something about the fundamental nature of the problem that I had overlooked earlier. (I won’t spoil the fun by saying what it was.) From that point, the solution was easy to implement:

module Main (main) where

import Control.Monad (liftM)
import Data.Array
import Data.Set (Set, empty, insert, member)
import System.Environment (getArgs)

main = do
    n:i:_ <- liftM (map read) getArgs
    print (shuffles n i)

shuffles :: Int -> Int -> Integer
shuffles n i =
    foldl lcm 1 . map toInteger . fst . foldl dfs ([], empty) $ deck'
  where
    (deck, deck')  = ([0 .. n-1], shuffle n i deck)
    perms          = array (0, n-1) (zip deck' deck)
    dfs (ls, vs) j = if member j vs then (ls, vs) else (l:ls, vs')
                     where (l, vs') = follow 0 j vs
    follow n i vs  = if member i vs then (n,vs)
                     else follow (n+1) (perms!i) (insert i vs)

shuffle n i =
    reverse . uncurry (flip interleave) . splitAt (n-i) . reverse

interleave (x:xs) (y:ys) = x : y : interleave xs ys
interleave xs     []     = xs
interleave []     ys     = ys

The following command compiles the program:

$ ghc -O2 -o shuffle --make PerfectShuffle.hs

The program computes the requested solution in about 4 ms on my 1.8-GHz box:

$ time ./shuffle 1002 101
5812104600

real    0m0.006s
user    0m0.004s
sys     0m0.004s

If you Google around, you can find other solutions, most of them implemented in Java.

Solve puzzles! They’re good for you.

Solving programming puzzles is a fun way to exercise parts of the brain that day-to-day coding rarely uses. If you are looking for some more puzzles, check out what’s archived at the Programming Fun Challenge page. Some are simple but others are downright tricksy.

Update 2006-03-24: Last night I thought of a simple optimization to my original implementation, and this morning I revised my code. The optimization reduces the run time for the (1002, 101) case from about 16 ms to about 4 ms. I have replaced the original code from this article with the new code, which is slightly longer. For comparison, here is the original implementation:

shuffles :: Int -> Int -> Integer
shuffles n i =
    foldl lcm 1 . map (fromIntegral . cycleLength) $ deck'
  where
    (deck, deck') = ([0..n-1], shuffle n i deck)
    perms         = array (0, n-1) (zip deck' deck)
    cycleLength j = follow j 1 (perms!j) :: Int
    follow i0 n i = if i == i0 then n else follow i0 (n+1) (perms!i)

Update 2006-03-25: I replaced the optimized code with a slightly more idiomatic version. I did this because I was guilt-tripped by a comment on Reddit saying that Haskell looked “ugly.” This code is, in fact, pretty ugly as far as Haskell goes. (Tip: Don’t judge a language based on a single sample, especially if it’s this one. If you want to see more beautiful code, my Haskell solutions to the 1996 ACM International Collegiate Programming Contest are much less offensive.)

Update 2006-11-04: Colorized the Haskell snippets.

"The "perfect shuffles" puzzle (solved in Haskell)" by Tom Moertel

Sun, 25 Feb 2007 11:46:40 -0500

Dear AnonymousCoward,

I’m fairly confident that the answer is not 13898745. If you want to know why, read on.

SPOILERS AHEAD

The cards at each position in the deck move to another position after each shuffle. If you trace the movements, you will see that they form cycles (and, in fact, must form cycles). The various cycles formed by this particular deck size and shuffling strategy have lengths of 9, 40, 50, 206, 230, 232, and 235. (Note that their sum is 1002.)

The cards that move through the 9-length cycle will return to their original positions in the deck after 9 shuffles. The cards in the 40-length cycle, however, will require 31 additional shuffles before they return to their original positions. But, at that time, the 9-length-cycle cards will again be out of their original positions. You have to shuffle the deck a total of 360 times – the least common multiple of 9 and 40 – before the cards in both cycles return to their original positions.

The same holds for all of the other cycles. Thus to return all of the cards in the deck to their original positions, you must shuffle the deck N times, where N is the least common multiple of all the cycle lengths. If you compute N, it turns out to be 5,812,104,600:

Prelude> foldl1 lcm [9,40,50,206,230,232,235] :: Integer
5812104600

Note that N is too large to be represented by a 32-bit integer. You’ll need to use some kind of “BigInt” type to compute it.

For additional explanations, try searching on Google for “perfect shuffles” 5812104600.

Cheers,
Tom

"The "perfect shuffles" puzzle (solved in Haskell)" by AnonymousCoward

Sun, 25 Feb 2007 04:13:52 -0500

Are you sure the answer is not 13898745?

"The "perfect shuffles" puzzle (solved in Haskell)" by Reg Braithwaite

Thu, 23 Mar 2006 17:06:42 -0500

Nice!

Tom Moertel's Weblog: The "perfect shuffles" puzzle (solved in Haskell)

The "perfect shuffles" puzzle (solved in Haskell)

Solve puzzles! They’re good for you.

"The "perfect shuffles" puzzle (solved in Haskell)" by Tom Moertel

"The "perfect shuffles" puzzle (solved in Haskell)" by AnonymousCoward

"The "perfect shuffles" puzzle (solved in Haskell)" by Reg Braithwaite