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.

Tom Moertel's Weblog: Tag shuffles

The "perfect shuffles" puzzle (solved in Haskell)

Solve puzzles! They’re good for you.