Implementation of the Solitaire Ciper from “Cryptonomicon”

solitaire_ciper.hs

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"