mult.ifario.us

In Part I and Part II, I introduced the problem and observed some properties of the problem. This part exploits some of those observations and describes a straightforward but possibly (probably) inefficient solution.

No Experimenting on People

Experimenting with Participants is awkward, and I introduced a Marked class in Part I in the interest of working with easier-to-manipulate data:

class Marked a where
    marker :: a -> String

to that end, I'd like to use the classic combinatorial experimental subject of colored balls instead:

data Ball = Red | Blue | Green | Purple | Orange
            deriving (Show,Enum,Bounded,Eq)

instance Marked Ball where
    marker b = [(head.show) b]

The following convenience functions provide either a randomly colored ball or a list of randomly colored balls:

ball :: Int -> Ball
ball = toEnum

random_ball :: IO Ball
random_ball = do { r < newStdGen
                 ; let (x,_) = randomR (fromEnum(minBound::Ball),
                                        fromEnum(maxBound::Ball)) r
                 ; return (toEnum x) }
                  
random_balls :: Int -> IO [Ball]
random_balls n = do { r < newStdGen
                    ; let rs = randomRs (fromEnum(minBound::Ball),
                                         fromEnum(maxBound::Ball)) r
                    ; return (map toEnum (take n rs)) }

For example, in ghci:

Main> :load secretsantas.lhs
[1 of 1] Compiling Main             ( secretsantas.lhs, interpreted )
Ok, modules loaded: Main.
*Main> x < random_ball
Green
*Main> y < random_balls 10
[Blue,Purple,Red,Purple,Blue,Purple,Green,Blue,Blue,Orange]
*Main> concat (map marker y)
"PPBORGOPOR"

The "<-" notation at the prompt is for binding a symbol to the result of an action in the IO monad. (This is explained in the ghci documentation.)

Idea of the Solution

Let's start with a raw list of marked items:

The first step is to gather together the consecutive entries with the same marker, like so:

Next, take one element from each segment and put the resulting list aside. Combine the leftovers together, eliminating any gaps and combining any adjacent groups with the same marker. Note that we're working on a circular list, so the leftmost and rightmost groups are adjacent. Continue until either all of the groups are gone or there is only a single group (all one marker) remaining. Here's a pictorial example:

In steps:

1. Collect one element from each group. No leftover groups are empty, so continue.
2. Collect one element from each group.
3. One leftover group is empty, so eliminate it. No adjacent leftover groups are the same marker, so continue.
4. Collect one element from each list.
5. Two leftover groups are empty, and once they are removed, the adjacent groups have the same marker (orange), so combine them.
6. Collect one element from each group.
7. Two leftover groups (purple and rightmost light green) are empty, so eliminate them. No adjacent groups are the same marker, so continue.
8. Collect one element from each group. No leftover groups are empty, so continue.
9. Collect one element from each group. The one leftover group consists of elements all with the same marker.

With the collected groups assembled, the last group of leftovers either fits or does not, and in this case, it's works out:

If it hadn't worked out, then there would have been no solution.

The Grouping Step in Haskell

Haskell has a well-chosen selection of list operations, so this is almost a one-liner:

segments :: Marked a => [a] -> [[a]]
segments = groupBy (\ x y = (marker x == marker y))

A quick note on notation: the backslash notation (it's supposed to look like a λ) is Haskell's syntax for inline function definition, and the expression defines the segments function by currying the first argument of groupBy with the function defined in-line. This isn't quite right, however, as the marker of the first group and the marker of the last group might be the same, so what we really want is a version that simulates grouping on a circular list:

align :: Marked a => [a] -> [a]
align x = let q = marker(last x) in
          f(g (q,[],x))
              where
                f (q,[],y) = y
                f (q,y,z) = z ++ (reverse y)
                g (q,y,[]) = (q,y,[])
                g (q,y,z@(w:ws)) | marker w == q = g (q,w:y,ws)
                g (q,y,z) = (q,y,z)

segments :: Marked a => [a] -> [[a]]
segments = (groupBy (\x y -> (marker x) == (marker y))).align

This is both a little ugly and has the desired behavior:

*Main> y < random_balls 10
[Blue,Green,Orange,Purple,Green,Blue,Blue,Orange,Blue,Blue]
*Main> segments y
[[Green],[Orange],[Purple],[Green],[Blue,Blue],[Orange],[Blue,Blue,Blue]]

It also behaves correctly for the two edge cases:

*Main> let y = [Blue,Blue,Blue] 
*Main> align y
[Blue,Blue,Blue]
*Main> let y = [Purple]
*Main> align y
[Purple]

But what about the other edge case, align []? The initial definition of q looks like it should cause an exception, as last [] is undefined. (Actually, [] isn't sufficiently specific to allow Haskell to evaluate it in ghci; the right thing is to qualify it as an empty list of Marked items, i.e., []::[Marked].) We could (and probably should) specify the behavior of align [], but laziness means that the definition of q is never evaluated in this case:

align [] = f(g (q,[],[]))
         = f((q,[],[]))
         = []

The Extraction and Simplification Step in Haskell

Back to the problem at hand, so long as the collected list has more than one entry, one element from each of the lists would meet the secret santa constraint because no two consecutive elements have the same marker, by construction. Stripping an element from each segment gives us a valid list fragment and a new list of segments, some of which may be empty. Implementing the "remove empties and combine common" step in Haskell is equivalent to flattening the leftover lists and re-executing the segment operation. Here's one function that both captures the first item in each group and prepares a new set of groups:

reap :: Marked a => [[a]] -> ([a],[[a]])
reap x = ((map head) x,(segments (concat ((map tail) x))))

And this works more or less as it should (with some line breaks added for legibility):

*Main> y < random_balls 25
[Green,Green,Green,Blue,Red,Purple,Purple,Purple,Orange,Purple,
 Orange,Purple,Blue,Green,Blue,Purple,Orange,Purple,Red,Blue,
 Blue,Green,Orange,Green,Blue]
*Main> reap (segments y)
([Green,Blue,Red,Purple,Orange,Purple,Orange,Purple,Blue,Green,
  Blue,Purple,Orange,Purple,Red,Blue,Green,Orange,Green,Blue],
 [[Green,Green],[Purple,Purple],[Blue]])

We're almost ready for a recursive solution, but not quite. We need to be able to collect the good lists reaped at each pass, and this uses the observation from Part II about combining orbits together. Combination of orbits in Haskell:

compatible :: Marked a => [a] -> [a] -> Bool
compatible x y = ((marker (head x)) /= (marker (last y))) &&
                 ((marker (head y)) /= (marker (last x))) 

combine :: Marked a => [a] -> [a] -> [a]
combine [] y = y
combine x [] = x
combine x y | compatible x y = x ++ y
combine x y = (reverse x) ++ y

And now a slightly fancier, recursive version of the reap function:

reap :: Marked a => ([a],[[a]]) -> ([a],[[a]])
reap (w,[]) = (w,[])
reap (w,x) | length x == 1 = (w,x)
reap (w,x) = reap (w `combine` ((map head) x),
                         (segments (concat ((map tail) x))))

*Main> y < random_balls 25
[Green,Orange,Purple,Green,Green,Purple,Orange,Blue,Blue,
 Green,Red,Green,Blue,Green,Purple,Orange,Blue,Blue,Orange,
 Purple,Green,Purple,Green,Purple,Purple]
*Main> reap ([],segments y)
([Green,Orange,Purple,Green,Purple,Orange,Blue,Green,Red,
  Green,Blue,Green,Purple,Orange,Blue,Orange,Purple,Green,
  Purple,Green,Purple],
 [[Green],[Blue,Blue],[Purple]])
*Main> reap it
([Green,Orange,Purple,Green,Purple,Orange,Blue,Green,Red,
  Green,Blue,Green,Purple,Orange,Blue,Orange,Purple,Green,
  Purple,Green,Purple,Green,Blue,Purple],
 [[Blue]])

Intermingling the Leftover Items in Haskell

Assuming that reap is run until either there are no leftovers or all of the leftovers are the same color, the next piece is a function that Maybe intermingles the leftover group (one Blue ball in the above example) into the list in the first coordinate. The intermingle function below models the circular list as two halves, and moving one place in the circular list is modeled as moving the head of the third coordinate to the head of the second coordinate; the list of leftovers is passed in the first coordinate.

intermingle :: Marked a => ([a],[a],[a]) -> ([a],[a],[a])
intermingle ([],y@(y1:y1s),y2) = ([],reverse(y) ++ y2,[])
intermingle ([],[],y) = ([],y,[])
intermingle ((x:xs),y,[]) = ((x:xs),y,[])
intermingle (x:xs,[],y@(y1:ys)) | (marker x /= marker y1) &&
                                  (marker x /= marker (last y))
                                      = (xs,[],x:y)
intermingle ((x:xs),y@(y1:y1s),(y2:y2s)) | (marker x /= marker y1) &&
                                           (marker x /= marker y2)
                                               = intermingle (xs,y2:(x:y),y2s)
intermingle (x,y,(y2:y2s)) = intermingle (x,y2:y,y2s)

With the example from above with the one leftover Blue, intermingle returns the one Blue at the head of the list, as the third rule would define:

*Main> intermingle ((snd it)!!0,[],fst it)
([],[Blue,Green,Orange,Purple,Green,Purple,Orange,Blue,Green,
 Red,Green,Blue,Green,Purple,Orange,Blue,Orange,Purple,Green,
 Purple,Green,Purple,Green,Blue,Purple],
 [])

The intermingle function also does the right thing when there is no solution:

*Main> intermingle ([Red,Red,Red],[],[Green,Green])
([Red],[Green,Red,Green,Red],[])

Putting it All Together

Now we can pull the pieces together into a function that solves the original problem:

result :: Marked a => ([a],[a],[a]) -> Maybe [a]
result ([],y,[]) = Just y
result ((x:xs),_,[]) = Nothing
result (_,_,z) = error "Not expecting to see data in the third coordinate."

santa_solve :: Marked a => [a] -> [a]
santa_solve x  = case outcome of { Nothing -> error "No solution."
                                 ; (Just w) -> w }
    where
      reaped = reap ([],segments x)
      leftovers = concat(snd reaped)
      partial_solution = fst reaped
      outcome = result (intermingle (leftovers,
                                     [],
                                     partial_solution))

Our <50 lines of Haskell work like a charm:

*Main> santa_solve [Red,Green,Blue,Red,Red]
*** Exception: No solution.
*Main> y < random_balls 300
**Main> concat ((map marker) (santa_solve y))
"OROGORPBPGRGRPBGRPGOBGORPOBGOBPGPORGBORGBOPRGBPRGBGOPOPGOGP
 RBRGRGBOGBPRPRPRPOGBPGPGPGORBOBGRBPBPRGBRPGBROBRBGPRPORGPRG
 PBGPGORGBPORBRPRPGPGORORGBPGPGOBRPGROPOROGOROBPGBGBGBOGOPOB
 ORBPOPORPRPRPOGOPBPOGROBOGBPOGOPGPBRPGPGBROBPBRGBOBPRBPGOGP
 RPOPROBPRORGORPGPBRGRPRBOROBOROPBRPRBRGORGBPGRGPOPOGBPGPOGP
 GPOGP"

Including the data structure and parsing code for Participants from Part I (but not including the code to generate random lists of Balls), a nicely-formatted Haskell solution weighs in at under 100 lines without sending email.

This implementation is more than fast enough for most practical purposes, but it's still far from optimal. On my development box, running a compiled santa_solve on 10⁶ balls takes 1-2 seconds, and processing 10⁷ takes ~50 seconds. If I have time before I get distracted, I'll come back to a more efficient approach. (For what it's worth, one path to a more efficient solution would be to sort the initial list and do away with the successive flattening and grouping.)

Part I set up a data structure and covered input and output, so it's back to the problem at hand. This post establishes a useful equivalence and establishes a strong condition on the existence of a solution.

From Orbits to Lists

From a purely academic perspective, it's worth observing that there aren't always solutions to the Secret Santa problem. For example, the degenerate case of only a single family is one unsolvable case, but it's also the case that if a single family comprises more than half of the participants, then there is no solution (by the pigeonhole principle). A more useful observation is that the problem of a mapping can easily be turned into a problem of lists.

First, observe that if there is a circular list that contains each of the members of P (the set of participants from Part I) exactly once where no two consecutive list elements have the same last name, then the successor function is a secret santa function. Conversely, if there is any secret santa function, it can be used to generate such a list, as follows. (It is not the case that every secret santa function arises from a list.) For a secret santa function s, the orbits of elements of P are a finite number of disjoint subsets, each of which has the form a of a circular list of elements of P where no two consecutive elements have the same last name. If there are at least two orbits O1 and O2, combine the two of them by breaking each orbit at a randomly selected element and concatenating the two lists head-to-tail and tail-to-head to get a new circular list, like so:

If O1 merged with O2 violates the successor condition, then O1 merged with O2 in reverse order does not. Sketch the cases on a piece of paper if this isn't obvious; in brute-force terms, it would look something like this:

The two colors squares in a column or row heading represent the "ends" of the broken circular lists, and concatenation is performed by gluing the two entries touching the table and the two entries not touching the table; a yellow square indicates that one of the lists should be reverse prior to gluing. For example, the upper left square would be R...G + G...R or, after reversing the second list, R...G + R...G, which is a legal combination.

This proves that if there is a secret santa function that decomposes the set into n>1 orbits, then there is a secret santa function that decomposes it into n-1 orbits. Thus, to create a solution, it's enough to create a circular list that exhausts P and where no two markers are repeated.

Orbits and Drafting

The observation above about there being no solution when one family is larger than the sum of all of the other families can be strengthened: that is the only case when there is no solution. The idea of the proof is to sort the families by size and then draft members from the smallest family into the second largest family, as depicted below:

In the image, each layer is an orbit, and the diagram up to the top of the yellow-green (i.e., second largest) family represents a valid secret santa function. The yellow-green family can continue to draft members from the smallest family until either the yellow-green and dark red families are the same size or until the smaller families are exhausted, i.e., the dark red family contains more members than the other families combined.

As an aside, a similar strategy works to obtain an as-rectangular-as-possible arrangement:

In Practice

Up next, a couple of posts (like this one, in the secretsanta tag) with solutions implemented using these ideas.

A while back I posted a solution to the first Ruby Quiz in Haskell. The next quiz problem is about "secret santas", which I'll rephrase as follows:

Given a set P of people, each with a first name, last name, and email address, define a bijective "secret santa" function s :: P -> P such that (last . s)(p) /= last(p) for all p in P, where last :: P -> String maps a person to their last name.

There are also some requirements about reading the names from a file and sending email, and I'll deal with those up front, here in Part I. Subsequent parts (all available under the secretsanta tag, in case you choose to follow the thread) contain some additional background on the problem (including a simple, strong characterization of when solutions exist) and a couple of solution techniques.

Reading and Writing People

Haskell has the Read and Show type classes that provide, respectively, the ability to read and write a type. Writing out one of the secret santa participants is straightforward:

data Participant = Participant (String,String,String)

first_name :: Participant -> String
first_name (Participant (f,_,_)) = f

last_name :: Participant -> String
last_name (Participant (_,l,_)) = l

email_addr :: Participant -> String
email_addr (Participant (_,_,a)) = a

instance Show Participant where
    show p = (last_name p) ++ ", " ++ (first_name p) ++ " <"
             ++ (email_addr p) ++ ">"

(Show and Read can be obtained in this case by deriving their implementations, but the representation is practical but not that appealing.) To read in the same representation, a very simple parser is preferable to implementing the low-level functions that Haskell requires (see, e.g., 8.3 of the GITH). Parsec makes it simple:

normalize :: String -> String
normalize = unwords.words

participant_parser :: Parser Participant
participant_parser = do { last_n <- many1 (letter <|> space)
                        ; char ','
                        ; first_n <- many1 (letter <|> space)
                        ; char '<'
                        ; email_a <- many1 (letter <|> oneOf ".-_@+")
                        ; char '>'
                        ; return (Participant (normalize first_n,
                                               normalize last_n,
                                               normalize email_a))
                        }

Parsec also makes it simple to parse a list of participants from a flat file, like so:

participants_parser :: Parser [Participant]
participants_parser = participant_parser `sepEndBy` (many1 newline)

load_participants :: String -> IO [Participant]
load_participants filename = do { result <- parseFromFile participants_parser filename
                                ; case (result) of 
                                    Left err -> (error (show err))
                                    Right val -> return val
                                }

If you're not a Haskell person, it's worth stopping to scratch your head about why the load_participants function creates values of type IO [Participant] instead of [Participant]. When I first started learning Haskell, I searched in vain for a function with a signature like f :: IO a -> a, but the nature of Haskell dictates that no such function can exist. (This is not a general trait of monads, as it's straightforward to unwrap Maybe or Either.) In a nutshell, IO exists to both separate and integrate the purely functional world where referential transparency reigns and the external world, and the list doesn't exist in the functional world until the I/O operation (reading the file) is performed, thus the need to deal with the inner value within an IO context, e.g., within a main function, in an interactive session, or by lifting functions into the IO monad.

Sending Email

There are two easy ways to send email. The simplest is to use the System.Cmd module included with the core libraries and the system function. The other way is the sendmail function from the Network.Email.Sendmail module in MissingH. Neither one is particularly exciting...

A Little Abstraction Goes a Long Way

Before I actually get going in the other parts, I'd like to introduce a layer of abstraction:

class Marked a where
    marker :: a -> String

instance Marked Participant where
    marker = last_name

This gets me out of having to type Participant everywhere and makes the functions easier to reuse, e.g., for balls where marker is color or animals where marker is species or music tracks where marker is artist and album, or...

Jim Burton started a thread on haskell-cafe about working the Ruby Quiz problems in Haskell, and I decided to give it a go. I can't say that I'll work them all, but here's my solution to the first problem — implementing Bruce Schneier's Solitaire encryption algorithm. Among other things, a solution provides a quick walk-through of using Haskell's built-in Enum classes and list operations.

Step 1: A Deck of Cards

One of the ingredients for the cipher is a deck of 52 cards, numbered bridge-style from the ace of clubs through the king of spades and then followed by two jokers with suits "A" and "B". I'd like to implement the deck as a 2-tuple of a suit Enum, where the two jokers come from different suits, and a face Enum, like so:

data Suit = Clubs | Diamonds | Hearts | Spades | A | B
            deriving (Enum, Show, Bounded, Eq)

data Face = Ace | Two | Three | Four | Five | Six | Seven 
          | Eight | Nine | Ten | Jack | Queen | King | Joker
            deriving (Enum, Show, Bounded, Eq)

The "deriving" expression is worth some explanation after a 30-second, 30,000-foot look at Haskell's type system. A class in Haskell is a set of assertions of the form "there exists a function f with signature..." and potentially some default definitions, and a type can be an instance of the class if it has functions that meet the assertions. For example, the Eq class is defined:

(==), (/=) :: a -> a -> Boolean

x /= y = not (x == y)
x == y = not (x /= y)

For a given type that would play the role of the a, it's up to the implementer to supply (==) and (/=) functions with the correct signatures. The second and third statements mean that if the implementer only defines one of the two, the other is defined in the standard way. Nonetheless, the precise semantics of the functions — e.g., whether == remotely resembles "equals" or whether x==y implies not(x/=y) — are up to the implementer.

Back to the Suit and Face enumerated type definitions, the deriving tells Haskell that the type is an instance of the listed classes by inheriting default implementations. In simplest terms:

• An instance of Enum has (at least) functions that convert from and to integer indices.
• An instance of Bounded has a least element and a greatest element.
• An instance of Show has a function to convert to a String.
• An instance of Eq has (at least) an == operator.

(The links above are to the Zvon Haskell reference.) Haskell supplies these functions by numbering the enumerated elements starting at 0. A quick example with ghci:

*Main> Ace
Ace
*Main> succ Ace
Two
*Main> succ it
Three
*Main> fromEnum Queen
11
*Main> Ace == Two
False

(In ghci, it refers to the last result.)

Now, with a little more effort, we can create a Card type that enumerates the deck as tuples of (Suit,Face), except that we want to supply a custom enumeration, either using dictionary ordering for a normal card or a custom index for the jokers:

data Card = Cd Suit Face
          deriving Eq

As above, this means that Haskell will supply an == for us, and it's important to have, e.g., to use functions like elemIndex:

Eq a => a -> [a] -> Maybe Int

I'll come to the Maybe monoid below, but the Eq a => means that the a in the definition must be an instance of Eq. Next up are a couple of convenience functions to access the components of a Card:

suit :: Card -> Suit
suit (Cd s _) = s

face :: Card -> Face
face (Cd _ f) = f

The Solitaire cipher imposes the bridge dictionary ordering on the deck with the A Joker and B Joker coming after the king of spades in the default order. So, the instance declaration that makes Card into an Enum:

instance Enum Card where
    toEnum 53 = (Cd B Joker)
    toEnum 52 = (Cd A Joker)
    toEnum n = let  d = n `divMod` 13
               in Cd (toEnum (fst d)) (toEnum (snd d))
    fromEnum (Cd B Joker) = 53
    fromEnum (Cd A Joker) = 52
    fromEnum c = 13* fromEnum(suit c) + fromEnum(face c)

Among other things, an instance of Enum makes the arithmetic sequence notation .. can be used to construct ranges, so the whole deck would be:

[(Cd Clubs Ace) .. (Cd B Joker)]

Note that typing this into ghci will result in an error. The type doesn't implement Show, so Haskell doesn't know how to display the elements of the list. This is easy enough to fix up:

show_suit :: Suit -> String
show_suit s = (take 1) (show s)

show_face :: Face -> String
show_face f = (take 1) (drop (fromEnum f) "A23456789TJQK$") 

instance Show Card where
    show c = (show_face (face c)) ++ (show_suit (suit c))

Now we can get a look at our deck:

*Main> [(Cd Clubs Ace) .. (Cd B Joker)]
[AC,2C,3C,4C,5C,6C,7C,8C,9C,TC,JC,QC,KC,
 AD,2D,3D,4D,5D,6D,7D,8D,9D,TD,JD,QD,KD,
 AH,2H,3H,4H,5H,6H,7H,8H,9H,TH,JH,QH,KH,
 AS,2S,3S,4S,5S,6S,7S,8S,9S,TS,JS,QS,KS,
 $A,$B]

(The linebreaks are added.) We're almost done, but the Solitaire cipher assigns different values to the cards than our enumeration does, so we wrap that up in a function:

value :: Card -> Int
value (Cd B Joker) = 53
value c = fromEnum c + 1

Step 2: Implement Shuffling

The Solitaire cipher uses a shuffling algorithm to generate a sequence of letters from the cards in the deck (thus the name for the cipher), and the next step is to implement the shuffling algorithm on top of the Card data type. There are three fundamental operations:

• "Move down" moves a card down in the deck. The deck is imagined to be circular, so moving a card "down" really involves swapping it with the card immediately below, where the card below the bottom of the deck is the top of the deck.
• "Triple cut" fixes the (inclusive) interval between two cards and swaps the top and bottom portions.
• ""Count cut" takes a number of cards off the top of the deck equal to the value of the card on the bottom of the deck and inserts those above the bottom card.

One approach would be to model these three operations as functions:

m :: Card -> [Card] -> [Card]             -- "move down"
t_cut :: Card -> Card -> [Card] -> [Card] -- "triple cut"
c_cut :: [Card] -> [Card]                 -- "count cut"

With these in hand, the shuffle algorithm is:

c_cut ( (t_cut ja jb) ( (m jb) ((m jb) ( (m ja) ( deck )))))

where I'm using ja for (Cd A Joker) and jb for (Cd B Joker).

The whole implementation, complete with some inelegant bits for improvement, is here (or pretty-printed code here) and works:

*Main> encode "Code in Ruby, live longer!"
"GLNCQMJAFFFVOMBJIYCB"
*Main> decode it
"CODEINRUBYLIVELONGER"

Not all of the code is that pretty (I got a little bored toward the end...), so I'll just include a snippets here that demonstrate basic list handling and Maybe.

Maybe is a convenience that sidesteps the null return type problem in other languages. For example, here's a function that splits a String into five-character groups with all non-letters removed, all letters capitalized, and the last group padded:

cleanse :: String -> String
cleanse c = (map toUpper) ((filter isAlpha) c)

pad :: Int -> Char -> String -> String
pad n c s | length s < n = s ++ (replicate (n-length s) c)
pad n c s = s

maybe_split :: String -> Maybe(String,String)
maybe_split [] = Nothing
maybe_split s | w == "" = Just (pad 5 'X' s,w)
              | True = Just (take 5 s, w)
              where w = drop 5 s

quintets :: String -> [String]
quintets s = (unfoldr maybe_split) (cleanse s)

The Nothing value is just that, while Just wraps a real value. (Note that Nothing is outside of the normal value space of the wrapped type, so unlike null, this makes the semantics of "no return value" explicit.) The unfoldr function is a way to generate a list by repeatedly applying a function. It appends the first component of the return value to the list and then applies the function to the second component until the function returns Nothing. The quintets is almost the pretty-print routine discussed in the quiz and in the cipher:

*Main> quintets "That was an interesting exercise."
["THATW","ASANI","NTERE","STING","EXERC","ISEXX"]
*Main> concat (intersperse " " it)
"THATW ASANI NTERE STING EXERC ISEXX"

That said, the pretty-printed version is useless for computing the cipher...

I can think of a few ways to make this more elegant and efficient, and maybe I'll give that a shot later. In the meantime, hopefully it's an entertaining example.

---

Update. There is now a page on the Haskell wiki devoted to solutions.