The "perfect shuffles" puzzle (solved in Haskell)

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.

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)