Permutations: an exercise

A colleague of mine severely nerd-sniped me at work recently with this rather innocuous-sounding challenge. I think it's a rather lovely little exercise and decided to write up my solution.

This post is designed to be read as a programming exercise. It will guide you along as it helps you break the problem into parts. If you want, you can skip to the end and read all the solutions (but that would be cheating).

Download the literate haskell source file first; you can fill in the gaps and then compile it with ghc permutations.lhs or load it into GHCi with :l permutations.lhs, like any other haskell file.

Consider the following shuffling technique:

  1. Take one card from the top of the deck and discard it into a second pile.
  2. Take another card from the top of the deck, and put it at the bottom of the deck.
  3. Repeat these two steps, putting all discarded cards from step 1 into the same pile, until the original deck is all gone and the second pile has all the cards in it.

For example, suppose we have a deck with 5 cards. The process looks like this:

The problem is: how many shuffles does it take until a deck is in the same order as when you started, for a deck with an arbitrary number of cards? Write a function, f :: Int -> Int, such that, for a deck with n cards, f n is the minimum number of shuffles required to return it to its original order.

We're going to use Haskell, because this is all about functions (in the mathematical sense), and so Haskell, being a functional programming language, is especially well suited to the job.

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where

import Control.Monad (forM_)
import Data.Maybe (catMaybes)
import Data.List (nub, sort)
import System.Environment (getArgs)
import Test.QuickCheck hiding (infiniteList)

todo :: a
todo = error "todo"

A Card is represented as an Int, except that the type checker should ensure that we don't put a Card where an Int should go, or vice versa.

newtype Card = Card { unCard :: Int }
    deriving (Eq, Ord, Arbitrary)

instance Show Card where
    show = show . unCard

We will represent a deck of cards as a list. The head of the list will represent the top of the deck.

type Deck = [Card]

unCardAll :: Deck -> [Int]
unCardAll = map unCard

makeDeck :: Int -> Deck
makeDeck n = map Card [1..n]

Our first job is to define a function that only performs steps 1 and 2 of the shuffle. What type should this function be? It should take a deck and a new pile, and return an updated deck and pile, so let's go with (Deck, Deck) -> (Deck, Deck).

step :: (Deck, Deck) -> (Deck, Deck)
step = todo

Now, we should think about what properties our step function should satisfy, so that we can get QuickCheck to test them for us. Here's one: after performing step some arbitrary number of times on a deck, we should end up with the same number of cards that we started with:

prop_step_sameLength :: Deck -> Int -> Bool
prop_step_sameLength deck n' =
    sumLength (times n step (deck, [])) == length deck
    where
    n = (abs n') `mod` (length deck + 1)
    times m f z = iterate f z !! m
    sumLength (a, b) = length a + length b

Here's another: after one step, we should have one fewer card in the deck (unless we started with an empty deck, in which case we should still have an empty deck)

prop_step_oneFewer :: Deck -> Bool
prop_step_oneFewer deck =
    length (fst (step (deck, []))) == newLength deck
    where
    newLength [] = 0
    newLength d = (length d) - 1

Write step and make sure it satisfies these properties before continuing! You can run the tests by typing runhaskell permutations.lhs, or by loading it into GHCi and typing main.

Next we need to write a function, shuffle, that performs the shuffle on a deck. So its type should be Deck -> Deck. Here are some Prelude functions that might come in handy:

shuffle :: Deck -> Deck
shuffle = todo

Test properties for shuffle: shuffling a deck should return another deck with the same number of cards:

prop_shuffle_sameLength :: Deck -> Bool
prop_shuffle_sameLength deck = length (shuffle deck) == length deck

Shuffling a deck should move the top card to the bottom:

prop_shuffle_topToBottom :: Deck -> Bool
prop_shuffle_topToBottom [] = True
prop_shuffle_topToBottom deck@(topCard:_) =
    last (shuffle deck) == topCard

Next up is a function order which, given a function, gives us the number of times we have to apply it to a given value to get that value again. So its type should be Eq a => (a -> a) -> a -> Int. We need the Eq constraint so that we can test values to see if they're the same as the first one.

order :: Eq a => (a -> a) -> a -> Int
order = todo

To test order: Suppose we have a function f, and some arbitrary number n. Define f such that f(x) is x - 1 for positive x, and n otherwise. Then, the number of times we have to apply f to n to get n again should be n + 1:

prop_order_subtractOne :: Int -> Bool
prop_order_subtractOne n' = order f n == n + 1
    where
    n = abs n' + 1 -- ensure that n >= 1
    f x | x > 0     = x - 1
        | otherwise = n

For our first attempt at answering the question, we can use a naive solution, which is just to keep shuffling the deck until we get the same deck again. We've got all the building blocks now, and all that remains is to put them together.

f1 :: Int -> Int
f1 = todo

f1 is easier to test by looking at particular cases. This code gives a few inputs and expected outputs for f. If you run the tests (with runhaskell permutations.lhs, as before) it will check that your f1 works for all of these values.

examples_f :: [(Int, Int)]
examples_f =
    [ (4, 2)
    , (5, 5)
    , (52, 510)
    , (53, 53)
    , (100, 120)
    ]

Now try doing f1 200, which should give you 8460. Notice how long it takes to compute. We can do much better than this, but in order to improve our implementation, we need to do some maths.

shuffle is a function of type Deck -> Deck, but we can also imagine it like a function S -> S, where S is the set of natural numbers from 1 up to n. Let's call this new function g. g takes the initial position of a card in the deck, and gives you the position after shuffling the deck once. So in the case where n = 5, we have:

g :: S -> S
g x = case x of
    1 -> 5 -- The card on top goes to the bottom
    2 -> 1 -- The card second from the top goes to the top
    3 -> 4 -- and so on
    4 -> 2
    5 -> 3

What do we know about this function?

Firstly, we know that this function must be injective, that is, each output corresponds to exactly one input. This is true because we can't end up with two cards in the same position after shuffling.

We also know that it must be surjective, which means that for every position in the deck (ie every number from 1 up to n), after a shuffle, there must be one card that ends up at that position. If we have a deck of 5 cards, and we shuffle it, we must always end up with a deck where there is a card in the 1st position, and a card in the 2nd, 3rd, 4th, and 5th.

Another thing we know about this function is that it its domain (the set of values that it accepts as input) and its range (the set of values that its output is in) are the same. In our case g has S as its domain and its range.

A function that is both injective and surjective is called a bijective function, and a bijective function whose domain and range are the same is called a permutation. Permutations have some really nice properties, and knowing about these will help us write a correct and efficient program.

Here's another way of writing g:

g = (1 5 3 4 2)

This is called cycle notation, and is a useful way of writing permutations. It says that g takes 1 to 5, 5 to 3, 3 to 4, 4 to 2, and 2 back to 1.

We can tell from this notation that g has an order of 5, because the cycle has 5 numbers in it. Each time we apply g, we move the cycle around by 1 step; therefore moving the cycle around 5 times gets us back to where we started.

What about the permutation for a deck of 13 cards? In Haskell, it would look like this:

g :: S -> S
g x = case x of
    1 -> 13
    2 -> 2
    3 -> 12
    4 -> 6
    5 -> 11
    6 -> 3
    7 -> 10
    8 -> 5
    9 -> 9
    10 -> 1
    11 -> 8
    12 -> 4
    13 -> 7

In this case, g takes 1 to 13, 13 to 7, 7 to 10, and 10... back to 1. What can we do when the cycle doesn't have all of the numbers in it?

The answer is to take the next number that isn't in any of our cycles and make a new one. So given that one of the cycles in g is (1 13 7 10), we can start with 2, to get another cycle: (2). We are still missing 3, so start with 3 to get another cycle: (3 12 4 6). Repeat this until all of the numbers occur in at least one cycle:

g = (1 13 7 10)(3 12 4 6)(5 11 8)

We usually leave out one-cycles (eg: (2), (9)) because they don't change the meaning of the function.

Since no number appears in more than one of these cycles (another way of saying this is that they are disjoint), when trying to determine the order, we can consider each of them individually.

The first cycle has 4 elements, so on its own, it must have an order of 4. Does that mean g has an order of 4? No, because applying g four times to 5 gives us 11.

We know that (1 13 7 10) on its own has an order of 4, and so does (3 12 4 6). However, (5 11 8) has an order of 3. What's the minimum number of times we have to apply g to get all of these back to where they started?

The visualisation says that f, applied n times to any of the numbers in the big circles, gives you the number in the corresponding little circle. We start with n = 0, that is, the identity function; clicking 'Next' increments n, and clicking 'Prev' decrements it. If a number is mapped to itself then it is highlighted. The dots along the bottom show how often each of the cycles maps all of the numbers in it to themselves.

The answer, which hopefully is demonstrated by the visualisation, is the least common multiple of all of the cycle lengths. So in this case, it's 12.

So now we have a new way of calculating the order of the shuffle for a given deck size: do the shuffle once, use the resulting deck to work out how to represent the shuffle as a set of disjoint cycles, and then get the least common multiple of the cycle lengths.

First we need a way of representing a cycle in Haskell. Let's go with this:

newtype Cycle = Cycle [Int]
    deriving (Eq, Ord)

instance Show Cycle where
    show (Cycle xs) = "(" ++ join " " (map show xs) ++ ")"
        where
        join glue (y:ys) = y ++ (concatMap (glue ++) ys)
        join _ [] = ""

So the cycle for g when n = 5 would be:

g = Cycle [1,5,3,4,2]

There's a small problem here: suppose we make another Cycle from the list [5,3,4,2,1]. This Cycle still takes 1 to 5, 5 to 3, and so on, like g. So we should consider them to be the same. However, Haskell will look at the inner list to decide whether two cycles are equal. Because the lists are different, Haskell will think that the cycles are different.

We can get around this issue by saying that a Cycle should always start with its smallest element. So the second representation of g above would be invalid.

A good way of implementing this in Haskell is to define a smart constructor: a function like Cycle whose type is [Int] -> Cycle, but which makes sure our statement above holds. Then, as long as we remember to use our smart constructor rather than Cycle, we'll be ok.

If we were writing a proper program, we would probably define Cycle and its smart constructor in a separate module and then only export the smart constructor, to ensure that we don't make this mistake. Here it's probably not worth the effort.

The next task is to write this smart constructor function. Let's call it makeCycle. It should take an infinite list of cycling values, cut it off at the first instance where a value is repeated, and then return a Cycle where the smallest value comes first.

While implementing makeCycle, you might find it useful to define a function, rotate, which takes a list, takes one element from the front of the list, and puts it at the back. So, for example, rotate [1..5] == [2,3,4,5,1].

rotate :: [a] -> [a]
rotate = todo
makeCycle :: [Int] -> Cycle
makeCycle = todo

To test makeCycle: if we take an infinite periodically cycling list, drop some arbitrary number of elements from the front, and call makeCycle on it, we should get the same cycle as if we hadn't dropped any.

prop_makeCycle_drop :: [Int] -> Int -> Bool
prop_makeCycle_drop list' n' =
    makeCycle infiniteList == makeCycle (drop n infiniteList)
    where
    n = abs n' + 1   -- ensure n >= 1
    list = 1 : list' -- ensure list is nonempty
    infiniteList = cycle . nub $ list

Next: write a function that takes a Cycle and returns its length.

cycleLength :: Cycle -> Int
cycleLength = todo

Now we need to take a shuffle for an arbitrary sized deck and work out how to turn it into a list of disjoint cycles. The function g :: S -> S that came up earlier can help here. We will start by computing the graph of g. We can represent it with a list of pairs, (Int, Int), mapping inputs to outputs.

type PermutationGraph = [(Int, Int)]

Write a function that takes a shuffling function and a deck size, n, and returns the graph of the permutation for doing that shuffle on a deck with n cards. So for each input from 1 up to n there should be one pair in the result containing the input and the corresponding output. The order doesn't matter.

permutation :: (Deck -> Deck) -> Int -> PermutationGraph
permutation = todo

Here are some example inputs and outputs. (I've used sort so that the order doesn't matter). This says that, for example, the permutation graph for 4 should be [(4,1),(2,2),(3,3),(1,4)]. Again, these examples are included in the tests.

examples_permutation :: [(Int, PermutationGraph)]
examples_permutation =
    [ (4, sort [(4,1),(2,2),(3,3),(1,4)])
    , (5, sort [(2,1),(4,2),(5,3),(3,4),(1,5)])
    , (8, sort [(8,1),(4,2),(6,3),(2,4),(7,5),(5,6),(3,7),(1,8)])
    ]

Now we need to implement the algorithm I described earlier for decomposing a permutation into a product of disjoint cycles. First we should write a function that extracts one Cycle from a PermutationGraph. It should:

The infinite list should repeat periodically with all the values in a cycle; that is, the kind of value that makeCycle is expecting to get. So we've already done the last step of implementing this function; we just need to apply makeCycle to that infinite list.

extractCycle :: PermutationGraph -> Cycle
extractCycle = todo

Next up is a function that can extract all the cycles from a permutation graph. Your implementation should use extractCycle repeatedly to get all of the cycles out of the list.

decompose :: PermutationGraph -> [Cycle]
decompose = todo

Another QuickCheck property: The sum of cycle lengths after decomposing the permutation graph for a given integer n should equal n:

prop_decompose_sumCycleLengths :: Int -> Bool
prop_decompose_sumCycleLengths n' = sumCycleLengths n == n
    where
    n = abs n' + 1
    sumCycleLengths =
          sum . map cycleLength . decompose . permutation shuffle

Once we have decomposed a permutation into a product of disjoint cycles, the final step is finding the least common multiple of their lengths. Write a function that takes a list of Ints, and returns the least common multiple of all of them. The Prelude gives us lcm, but it works on two numbers. You might find it helpful here.

lcm' :: [Int] -> Int
lcm' = todo

We have all the building blocks now: write another implementation of f using shuffle, permutation, decompose, cycleLength, and lcm'.

f2 :: Int -> Int
f2 = todo

Now that we have two different implementations of f, we can test to see whether we got them both right by seeing if they are equal. Because their implementations are quite different this will probably be quite a good indication of whether we got it right.

prop_f1_f2_identical :: Int -> Bool
prop_f1_f2_identical x = f1 x == f2 x

You did it! See how much faster f2 is? My answers are here if you want to compare them. For extra credit, get QuickCheck to test that the Faro shuffle will return a deck to its original order after 8 shuffles.

Below here is code that you don't need to worry about.

This code tests a function based on a set of example inputs and outputs. It takes a list of test inputs and expected outputs and a function mapping inputs to outputs, and returns an action that checks whether the expected outputs are the same as the actual outputs. If they are all ok, it prints a message saying so; otherwise, it prints details of all the examples that failed.

testByExamples :: (Show a, Show b, Eq b) => [(a, b)] -> (a -> b) -> IO ()
testByExamples examples f =
    let fails = catMaybes $ map runExample examples
    in if null fails
        then putStrLn "+++ OK, passed all examples."
        else forM_ fails printFailure
    where
    runExample (input, expected) =
        let actual = f input
        in if expected == actual
            then Nothing
            else Just (input, expected, actual)
    printFailure (input, expected, actual) =
        putStrLn $ concat
            [ "failed on input "
            , show input
            , ": expected <"
            , show expected
            , ">, got <"
            , show actual
            , ">."
            ]

This is what gets run when you type runhaskell permutations.lhs. It says that if we get a number as an argument, calculate f2 for that number and print it. Otherwise, run the tests.

main :: IO ()
main = do
    args <- getArgs
    case args of
        x:_ -> do
            print . f2 . read $ x
        _   -> do
            let qc :: Testable a => a -> String -> IO ()
                qc prop msg =
                    putStrLn ("Testing: " ++ msg) >>
                        quickCheck (sensible prop)
            let te exs f msg =
                    putStrLn ("Testing: " ++ msg) >>
                        testByExamples exs f
            qc prop_step_sameLength "prop_step_sameLength"
            qc prop_step_oneFewer "prop_step_oneFewer"
            qc prop_shuffle_sameLength "prop_shuffle_sameLength"
            qc prop_shuffle_topToBottom "prop_shuffle_topToBottom"
            qc prop_order_subtractOne "prop_order_subtractOne"
            te examples_f f1 "examples for f1"
            qc prop_makeCycle_drop "prop_makeCycle_drop"
            te examples_permutation
                  (sort . permutation shuffle) "examples for permutation"
            qc prop_decompose_sumCycleLengths
                  "prop_decompose_sumCycleLengths"
            te examples_f f2 "examples for f2"
            qc prop_f1_f2_identical "prop_f1_f2_identical"
    where
    sensible :: Testable a => a -> Property
    sensible = mapSize (floor . logBase (2 :: Double) . fromIntegral)

I don't host comments on my blog, but if you have thoughts or questions, you can let me know on Twitter: @hdgarrood