Personal tools

Haskell Quiz/The Solitaire Cipher/Solution JFoutz

From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)
Jump to: navigation, search
m (i wish i could spell. solitare -> solitaire)
m
 
Line 23: Line 23:
   
   
drawMsg msg = concat $ intersperse " " (loop msg)
+
drawMsg msg = unwords (loop msg)
 
where loop msg
 
where loop msg
 
| length msg > 5 = (take 5 msg) : loop (drop 5 msg)
 
| length msg > 5 = (take 5 msg) : loop (drop 5 msg)
Line 32: Line 32:
 
decrypt msg = churn solSub msg
 
decrypt msg = churn solSub msg
   
main = do { x <- getArgs
+
main = do (x:xs) <- getArgs
; case (head x) of
+
case x of
"c" -> putStrLn $ crypt $ concat $ tail x
+
"c" -> putStrLn $ crypt $ concat $ xs
"d" -> putStrLn $ decrypt $ concat $ tail x
+
"d" -> putStrLn $ decrypt $ concat $ xs
 
_ -> putStrLn "Try solitaire c my message, or d my message"}
 
_ -> putStrLn "Try solitaire c my message, or d my message"}
   
Line 43: Line 43:
   
 
-- add and subtract base solitaire style
 
-- add and subtract base solitaire style
solAdd x y = mod (x + y) 26
+
solAdd x y = (x + y) `mod` 26
solSub x y = mod (x + 26 - y) 26
+
solSub x y = (x + 26 - y) `mod` 26
   
   

Latest revision as of 11:20, 21 February 2010


This took longer than expected. I didn't read the specification closely enough to realize both jokers count as 53 rather than A == 53 and B == 54

Other than that, looking through Data.List for shortcuts was educational. I really like zipWith and groupBy.

This could probably use a lot more orginization, and a bit more commentary. Fortunately the function names match the spec closely, which helps.


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 = unwords (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:xs) <- getArgs
          case x of
                 "c" -> putStrLn $ crypt $ concat $ xs
                 "d" -> putStrLn $ decrypt $ concat $ xs
                 _ -> putStrLn "Try solitaire 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 solitaire style
solAdd x y = (x + y) `mod` 26
solSub x y = (x + 26 - y) `mod` 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