public
Last active

Implementation of the Solitaire Ciper from “Cryptonomicon”

  • Download Gist
solitaire_ciper.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
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"

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.