[Haskell-cafe] Card trick

[Mark Carroll]

Having heard about an interesting card trick, I thought I'd try
implementing it in Haskell. With luck, I didn't make any mistakes.
I thought it was cool enough to be worth sharing with you guys.

-- Mark
-------------- next part --------------
> module CardTrick
> where
> import Data.List
> import Data.Maybe

This code is by Mark Carroll, based on a description by Chris Ball of some
aspects of the trick. A guest selects five cards at random from a standard
deck. The magician's assistant hands four of them to the magician, and the
magician reveals what the fifth was. offerToTrickster reveals the four
cards that are handed to the magician by their assistant. tricksterAnswers
reveals what the fifth card was, based on the order of the four. The two
functions are separate and outside any monad to make it clear that no
information is leaking between the two apart from the obvious. Note that
the necessary procedures are easy for people to learn and to perform. Chris
mentions that there is interesting further reading in an article by Michael
Kleber to be found at http://people.brandeis.edu/~kleber/Papers/card.pdf

Usage example:

let fiveCards = (Card Five Clubs, Card Five Spades, Card Jack Hearts, Card Ace Spades, Card Two Clubs)
let fourCards = offerToTrickster fiveCards
let fifthCard = tricksterAnswers fourCards
print fourCards >> print fifthCard

First, we define the suits of the cards. They are in ascending order of
traditional superiority so that they work intuitively with Ord, and are thus
easy for a human to sort just as the computer does.

> data Suit = 
>     Clubs | Diamonds | Hearts | Spades
>     deriving (Eq, Ord, Read, Show)

Then, we define the ranks of the cards. Again, they are in intending order of
superiority, but one may prefer to make aces low instead of high.

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

A card has a rank and a suit.

> data Card = 
>     Card { rank :: Rank,
>            suit :: Suit } 
>     deriving (Eq, Ord)

We can pretty-print cards.

> instance Show Card where
>     show (Card rank suit) = show rank ++ " of " ++ show suit

limitToRanks brings an integer into range such that it corresponds to one of
the card ranks. Out-of-bounds integers are considered to have been referring
to duplicate enumerations of ranks among which our canonical enumeration is
stacked.

> limitToRanks :: Int -> Int

> limitToRanks = flip mod $ fromEnum (maxBound :: Rank) + 1

Now, we define the function offerToTrickster that embodies the activity of the
magician's assistant in handing the magician four of the five guest-picked
cards.

> offerToTrickster :: (Card, Card, Card, Card, Card) ->
>                     (Card, Card, Card, Card)

> offerToTrickster (c1, c2, c3, c4, c5) =

We aggregrate the cards by suit, with the larger groups first. This allows us
to easily pluck out in w and x two cards (of the same suit) from the largest
group.

>     let ((w : x : ys) : zs) = 
>             sortBy compareLengths $ 
>             groupBy suitsEqual $ 
>             sortBy compareSuits [c1, c2, c3, c4, c5]

The remaining cards are in ys and zs. We collect them together and put them
into a predictable order by sorting them.

>         remainder = sort (ys ++ concat zs)

Now, we find how many ranks we must step up in order to get from x's rank to
w's rank, and vice-versa. If we step past the highest rank, we wrap back down
to the lowest rank.

>         xToW = limitToRanks (fromEnum (rank w) - fromEnum (rank x))
>         wToX = limitToRanks (fromEnum (rank x) - fromEnum (rank w))

We are going to tell the magician the suit of the card we retain by keeping
one of w or x, which are of the same suit, and giving the magician the other
as the first card of the four. We choose which card is which by finding the
card such that if we step up from it, we can reach the retained card in six or
fewer steps. We note how many steps we must step up from this first "suit"
card to the retained card.

>         (suitCard, distance) = if xToW < wToX then (x, xToW) else (w, wToX)

We encode the number of steps, the distance between the cards, as two numbers:
   (0, 0) = 1 steps
   (0, 1) = 2 steps
   (1, 0) = 3 steps
   (1, 1) = 4 steps
   (2, 0) = 5 steps
   (2, 1) = 6 steps

>         (firstOfThree, swapLastTwo) = quotRem (distance - 1) 2

Now we have chosen a suit card from the four we can give to the magician, we
have three cards left in which to encode how many ranks must be stepped up
from the suit card to find the rank of the retained card.

Of those three (remember, they are ordered), we pluck out one of them to
indicate the first number in our encoding. This will be the next card we give
to the magician.

>         firstCard = remainder !! firstOfThree

We find the remaining two cards.

>         unswappedLastTwo = delete firstCard remainder

To encode a 1 as the second number in our encoding, we swap these last two
cards.

>         lastTwo = (if swapLastTwo == 1 then reverse else id) unswappedLastTwo

So, the three cards that we used to encode the rank are exactly these,

>         [r1, r2, r3] = firstCard : lastTwo

And, we hand them to the magician, suit card first.

>      in (suitCard, r1, r2, r3)
>     where 

Note that we sort such that greater lengths come first.

>     compareLengths xs ys = compare (length ys) (length xs)

These functions allow us to easily group cards by suit.

>     compareSuits (Card _ suit1) (Card _ suit2) = compare suit1 suit2
>     suitsEqual card1 card2 = compareSuits card1 card2 == EQ

Now, we must encode the process that the magician uses to determine what the
retained card is from the four cards that were handed to them by their
assistant.

> tricksterAnswers :: (Card, Card, Card, Card) -> Card

We can immediately extract the rank from which we must step, and the suit of
the retained card.

> tricksterAnswers (Card baseRank retainedSuit, r1, r2, r3) =

The remaining three cards encode how many steps we must take to reach the rank
of the retained card. First, we number each of the last three cards by the
order in which the assistant originally had them.

>     let directory = zip (sort [r1, r2, r3]) [0..]

Then, we translate the order of the cards as they were handed to us to the
numbers that correspond to their ordering before they were swapped around.

>         [x, y, z] = map (fromJust . (flip lookup) directory) [r1, r2, r3]

The first card of the three, x, tells us the first number of our encoding. The
remaining two cards, y and z, were swapped if the second number was a 1.

>         offset = x * 2 + 1 + if y > z then 1 else 0

So, now we know the offset, we can calculate the rank of the retained card.

>         retainedRank = toEnum (limitToRanks (fromEnum baseRank + offset))

We are now in a position to tell the guest what the retained card was.

>      in Card retainedRank retainedSuit

Of course, if the guest suspects that we encoded the retained card's identity
in the ordering of the four cards that the magician saw, we can point out to
them that there are only twenty-four different orderings for four cards.