# Haskell Quiz/The Solitaire Cipher/Solution Dolio

### From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)

m (Haskell Quiz/The Solitaire Cipher moved to Haskell Quiz/The Solitaire Cipher/Solution Don) |
m (Simplify push, use unfoldr in scrub) |
||

Line 30: | Line 30: | ||

-- Scrubs/pads a string to turn it into the format expected by the cipher |
-- Scrubs/pads a string to turn it into the format expected by the cipher |
||

− | scrub = break5 . pad . filter isAlpha . map toUpper |
+ | scrub = join . intersperse " " . unfoldr split . pad . filter isAlpha . map toUpper |

where |
where |
||

pad l = l ++ replicate ((5 - length l) `mod` 5) 'X' |
pad l = l ++ replicate ((5 - length l) `mod` 5) 'X' |
||

− | break5 l |
+ | split [] = Nothing |

− | | null t = h |
+ | split l = Just $ splitAt 5 l |

− | | otherwise = h ++ " " ++ break5 t |
||

− | where (h, t) = splitAt 5 l |
||

-- Moves element e in l forward n places using the appropriate rules |
-- Moves element e in l forward n places using the appropriate rules |
||

Line 41: | Line 41: | ||

(Just i) = elemIndex e l |
(Just i) = elemIndex e l |
||

l' = delete e l |
l' = delete e l |
||

− | i' = if i + n >= length l then 1 + i + n else i + n |
+ | (t,b) = splitAt (n + i `mod` length l') l' |

− | (t,b) = splitAt (i' `mod` (length l)) l' |
||

-- Performs the triple cut |
-- Performs the triple cut |

## Revision as of 07:09, 26 October 2006

module Main where import Data.List import Data.Char import Data.Ix import Control.Monad import Control.Monad.State import System import System.Random data Card = A | B | C Int deriving (Eq, Show) type Deck = [Card] type Cipher a = State Deck a unkeyed = map C [1..52] ++ [A,B] isJoker c = c == A || c == B value (C i) = i value _ = 53 -- en/decodes upper case characters into a 0 - 25 Int representation -- (for easier arithmetic than 1 - 26) decode n = chr (n + 65) encode n = ord n - 65 -- Shuffles a given deck using n as the seed for the random generator shuffle n = map snd . sortBy (comparing fst) . zip (randoms $ mkStdGen n :: [Int]) where comparing f a b = compare (f a) (f b) -- Scrubs/pads a string to turn it into the format expected by the cipher scrub = join . intersperse " " . unfoldr split . pad . filter isAlpha . map toUpper where pad l = l ++ replicate ((5 - length l) `mod` 5) 'X' split [] = Nothing split l = Just $ splitAt 5 l -- Moves element e in l forward n places using the appropriate rules push n e l = t ++ [e] ++ b where (Just i) = elemIndex e l l' = delete e l (t,b) = splitAt (n + i `mod` length l') l' -- Performs the triple cut tcut l = bottom ++ middle ++ top where [i,j] = findIndices isJoker l (top, m) = splitAt i l (middle, bottom) = splitAt (1 + j - i) m -- Performs the counting cut ccut l = init bottom ++ top ++ [last bottom] where n = value (last l) (top, bottom) = splitAt n l -- Extracts a code from a given deck according to the appropriate rules. -- Returns Nothing in the event that a joker is picked extract l@(h:_) = if isJoker c then Nothing else Just (value c) where n = value h c = l !! n -- Gets the next code in the key stream getCode = do modify (ccut . tcut . push 2 B . push 1 A) deck <- get maybe getCode return (extract deck) -- Uses the function f and initial deck d to en/decrypt a message crypt f d = map decode . flip evalState d . mapM cipher . map encode where cipher a | inRange (0,25) a = getCode >>= return . flip mod 26 . f a | otherwise = return a decrypt = crypt (-) encrypt = crypt (+) crypto f = unlines . map f . map scrub . lines main = do (o:l) <- getArgs let deck = if null l then unkeyed else shuffle (read (head l)) unkeyed case o of "d" -> interact (crypto $ decrypt deck) "e" -> interact (crypto $ encrypt deck) _ -> putStrLn "Unrecognized option."