Instantly share code, notes, and snippets.

ehamberg/solitaire_ciper.hs Created Jan 19, 2011

What would you like to do?
Implementation of the Solitaire Ciper from “Cryptonomicon”
 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"