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 startDeck = map Card [1..52] ++ [JokerA] ++ [JokerB] -- ‘A’ represents 1, ‘B’ 2, … , ‘Z‘ represents 26 charNum :: Char -> Int charNum c = 1 + ord c - ord 'A' -- 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] insertAt i e l = take i' l ++ [e] ++ drop i' l where i' = if i <= length l then i else i `mod` length l -- regular cards have a value, 1 ≤ v ≤ 52, jokers have the value 53 cardVal :: Card Int -> Int cardVal (Card n) = n cardVal _ = 53 -- a counted cut takes n cards from the top of the deck and places them just -- over the bottommost card countedCut :: Deck -> Int -> Deck countedCut d n = (init . drop n) d ++ take n d ++ [last d] -- operation 1: the “A” joker is moved one card down the deck op1 :: Deck -> Deck op1 d = insertAt (i+1) JokerA (filter (/= JokerA) d) where i = fromJust $ elemIndex JokerA d -- operation 2: the “B” joker is moved two cards down the deck op2 :: Deck -> Deck op2 d = insertAt (i+2) JokerB (filter (/= JokerB) d) where i = fromJust $ elemIndex JokerB d -- 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 op3 d = d3 ++ [d!!min j1 j2] ++ d2 ++ [d!!max j1 j2] ++ d1 where joker c = c `elem` [JokerA, JokerB] j1 = fromJust $ elemIndex JokerA d j2 = fromJust $ elemIndex JokerB d d1 = take (min j1 j2) d d2 = takeWhile (not . joker) $ drop (min j1 j2 + 1) d d3 = drop (max j1 j2 + 1) d -- 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 op4 d = countedCut d ((last >>> cardVal) d) -- one step of the algorithm is the four operations above in sequence step :: Deck -> Deck step = op1 >>> op2 >>> op3 >>> op4 -- 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 keyDeck = foldl (\x c -> step (countedCut x (charNum c))) (step startDeck) -- a keyed deck is key stream, each card representing a number 1 ≤ n ≤ 52 keyStream :: Deck -> [Int] keyStream d@(c:cs) = [val | val /= 53] ++ keyStream (step d) where val = cardVal (d!!cardVal c) -- encryption adds each character value to the value of the corresponding key encrypt :: String -> String -> String encrypt key plaintext = five $ zipWith (\a b -> cAdd a (numChar b)) text keys where deck = keyDeck key keys = keyStream deck text = filter (/= ' ') plaintext cAdd a b = numChar (charNum a + charNum b) five (a:b:c:d:e:t) = a:b:c:d:e:' ':five t five s = s -- decryption subtracts each character value from the value of the -- corresponding key decrypt :: String -> String -> String decrypt key plaintext = zipWith (\a b -> cSub a (numChar b)) text keys where deck = keyDeck key keys = keyStream deck text = filter (/= ' ') plaintext cSub a b = numChar (charNum a - charNum b) main = do putStrLn $ encrypt "" "AAAAAAAAAA" putStrLn $ encrypt "FOO" "AAAAAAAAAAAAAAA" putStrLn $ encrypt "CRYPTONOMICON" "SOLITAIRE"