Haskell Quiz/The Solitaire Cipher/Solution JFoutz

From HaskellWiki
< Haskell Quiz‎ | The Solitaire Cipher
Revision as of 18:19, 17 March 2007 by Jfoutz (talk | contribs) (marking code)
Jump to navigation Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.


import Data.Char
import Data.List
import System

-- discard any non a to z characers, uppercase the rest
-- split into groups of 5, padded with 'X'

prep ls = loop $ map toUpper $ filter (\x -> and [isAscii x, isLetter x]) ls
    where loop [] = []
          loop ls 
              | length ls < 5 = [take 5 (ls ++ "XXXX")]
              | otherwise = (take 5 ls) : loop (drop 5 ls)


drawMsg msg = concat $ intersperse " " (loop msg)
    where loop msg
              | length msg > 5 = (take 5 msg) : loop (drop 5 msg)
              | otherwise = [msg]

churn f msg = drawMsg $ toChr $ zipWith f (toNum $ concat $ prep msg) (keyStream [1..54])
crypt msg = churn solAdd msg
decrypt msg = churn solSub msg

main = do { x <- getArgs
          ; case (head x) of
                 "c" -> putStrLn $ crypt $ concat $ tail x
                 "d" -> putStrLn $ decrypt $ concat $ tail x
                 _ -> putStrLn "Try solitare c my message, or d my message"}

-- letters to numbers and back
toNum = map (\x -> ord x - 65)
toChr = map (\x -> chr (x + 65))

-- add and subtract base solitare style
solAdd x y = mod (x + y) 26
solSub x y = mod (x + 26 - y) 26


--keyStream
down1 x ls = move $ break (==x) ls
    where move (x:xs, t:[]) = x:t:xs
          move (xs, c:n:cx) = xs ++ n : c : cx

down2 x ls = down1 x $ down1 x ls


notEither a b = (\x y -> x /= a && y /= a && x /= b && y /= b)
tripleCut a b ls = swap a b $ concat $ reverse $ groupBy (notEither a b) ls

swap a b [] = []
swap a b (x:xs)
     | a == x = b : swap a b xs
     | b == x = a : swap a b xs
     | otherwise = x : swap a b xs
                   
cardVal c = if c == 54 then 53 else c
countCut ls = glue $ splitAt (cardVal $ last ls) (init ls)
    where glue (f,b) = b ++ f ++ [last ls]

jokerA = 53
jokerB = 54

keyStep deck = countCut $ tripleCut jokerA jokerB $ down2 jokerB $ down1 jokerA deck

getCard deck = deck !! (cardVal $ head deck)

keyStream deck = let d2 = keyStep deck 
                     out = getCard d2
                 in if out == jokerA || out == jokerB
                    then keyStream d2
                    else out : keyStream d2