Create a gist now

Instantly share code, notes, and snippets.

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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment