I finally read Neal Stephenson’s book *Cryptonomicon* this summer which – besides being a great read – introduced an interesting cipher called *Pontifex*. This cipher is based on the Solitaire cipher by Bruce Schneier and the idea is that one simply needs a deck of card in order to communicate securely if a list of keys has been exchanged. When seeing that yesterday’s challenge on Programming Praxis was to implement this cipher I simply *had* to do it, and here’s the resulting implementation, in Haskell, of the Solitaire cipher:

```
import Data.Char (ord, chr)
import Data.List (elemIndex)
import Data.Maybe (fromJust)
import Control.Arrow
data Card a = Card a | JokerA | JokerB deriving (Show, Eq)
type Deck = [Card Int]
-- we start with a deck in bridge order
startDeck :: Deck
= map Card [1..52] ++ [JokerA] ++ [JokerB]
startDeck
-- ‘A’ represents 1, ‘B’ 2, … , ‘Z‘ represents 26
charNum :: Char -> Int
= 1 + ord c - ord 'A'
charNum c
-- 1 = ‘A’, … , 26 = ‘Z’, 27 = ‘A’, …
numChar :: Int -> Char
numChar n| n > 26 = numChar (n-26)
| otherwise = chr (n+ord 'A'-1)
-- insert an element at a given position in a list
insertAt :: Int -> a -> [a] -> [a]
= take i' l ++ [e] ++ drop i' l
insertAt i e l = if i <= length l
where i'
then i`mod` length l
else i
-- regular cards have a value, 1 ≤ v ≤ 52, jokers have the value 53
cardVal :: Card Int -> Int
Card n) = n
cardVal (= 53
cardVal _
-- a counted cut takes n cards from the top of the deck and places them just
-- over the bottommost card
countedCut :: Deck -> Int -> Deck
= (init . drop n) d ++ take n d ++ [last d]
countedCut d n
-- operation 1: the “A” joker is moved one card down the deck
op1 :: Deck -> Deck
= insertAt (i+1) JokerA (filter (/= JokerA) d)
op1 d = fromJust $ elemIndex JokerA d
where i
-- operation 2: the “B” joker is moved two cards down the deck
op2 :: Deck -> Deck
= insertAt (i+2) JokerB (filter (/= JokerB) d)
op2 d = fromJust $ elemIndex JokerB d
where i
-- operation 3: a triple-cut swaps all the cards above the highest joker in the
-- deck with all the cards below the lowest joker in the deck, leaving the two
-- jokers and the cards between them in place
op3 :: Deck -> Deck
= d3 ++ [d!!min j1 j2] ++ d2 ++ [d!!max j1 j2] ++ d1
op3 d = c `elem` [JokerA, JokerB]
where joker c = fromJust $ elemIndex JokerA d
j1 = fromJust $ elemIndex JokerB d
j2 = take (min j1 j2) d
d1 = takeWhile (not . joker) $ drop (min j1 j2 + 1) d
d2 = drop (max j1 j2 + 1) d
d3
-- operation 4: a counted cut, based on the number of the bottom card in the
-- deck, moves the top “count” cards to just above the bottom card
op4 :: Deck -> Deck
= countedCut d ((last >>> cardVal) d)
op4 d
-- one step of the algorithm is the four operations above in sequence
step :: Deck -> Deck
= op1 >>> op2 >>> op3 >>> op4
step
-- keying a deck consists of one step, and then, for each character in the key,
-- do a counted cut on the number of the current character followed by another
-- single step
keyDeck :: String -> Deck
= foldl (\x c -> step (countedCut x (charNum c))) (step startDeck)
keyDeck
-- a keyed deck is key stream, each card representing a number 1 ≤ n ≤ 52
keyStream :: Deck -> [Int]
@(c:cs) = [val | val /= 53] ++ keyStream (step d)
keyStream d= cardVal (d!!cardVal c)
where val
-- encryption adds each character value to the value of the corresponding key
encrypt :: String -> String -> String
= five $ zipWith (\a b -> cAdd a (numChar b)) text keys
encrypt key plaintext = keyDeck key
where deck = keyStream deck
keys = filter (/= ' ') plaintext
text = numChar (charNum a + charNum b)
cAdd a b :b:c:d:e:t) = a:b:c:d:e:' ':five t
five (a= s
five s
-- decryption subtracts each character value from the value of the
-- corresponding key
decrypt :: String -> String -> String
= zipWith (\a b -> cSub a (numChar b)) text keys
decrypt key plaintext = keyDeck key
where deck = keyStream deck
keys = filter (/= ' ') plaintext
text = numChar (charNum a - charNum b)
cSub a b
= do
main $ encrypt "" "AAAAAAAAAA"
putStrLn $ encrypt "FOO" "AAAAAAAAAAAAAAA"
putStrLn $ encrypt "CRYPTONOMICON" "SOLITAIRE" putStrLn
```