# Haskell Quiz/The Solitaire Cipher/Solution Stoltze

### From HaskellWiki

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

Line 1: | Line 1: | ||

+ | [[Category:Haskell Quiz]] | ||

<haskell> | <haskell> | ||

module Main where | module Main where |

## Revision as of 22:15, 2 January 2008

module Main where import Char import List data Card = Card Int | JokerA | JokerB deriving (Show, Eq) instance Enum Card where fromEnum JokerA = 53 fromEnum JokerB = 54 fromEnum (Card n) = n toEnum n | n == 53 = JokerA | n == 54 = JokerB | otherwise = Card n succ JokerB = Card 1 getValue :: Card -> Int getValue (Card n) = n getValue JokerA = 53 getValue JokerB = 53 deck :: [Card] deck = [Card 1 .. JokerB] alphabet :: [Char] alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" letterToNumber :: Char -> Int letterToNumber ch = f' 1 ch where f' n ch = if alphabet !! (n-1) == ch then n else f' (n+1) ch numberToLetter :: Int -> Char numberToLetter n | n < 1 = numberToLetter (n + 26) | n > 26 = numberToLetter (n - 26) | otherwise = alphabet !! (n - 1) -- Not really needed, but since they specified cutting it into chuncks of 5, I thought I'd comply splitInto :: Int -> [Char] -> [Char] splitInto n list = concat $ intersperse " " $ splitInto' n list where splitInto' n list | null list = [] | length list < n = [list ++ replicate (n - length list) 'X'] | otherwise = [take n list] ++ splitInto' n (drop n list) -- Takes some words and a function for parsing. Since encode and decode were very similar, I thought this would be easier process :: [Char] -> (Int -> Int -> Int) -> [Char] process line fn = let noSpaces = map toUpper $ filter isAlpha line key = genKey $ length noSpaces keyvalues = map letterToNumber key linevalues = map letterToNumber noSpaces newline = map (\(x, y) -> numberToLetter (fn x y)) $ zip linevalues keyvalues in splitInto 5 newline encode :: [Char] -> [Char] encode line = process line (\line key -> line + key) decode :: [Char] -> [Char] decode line = process line (\line key -> line - key) -- Generates the keycode genKey :: Int -> [Char] genKey n = repl n deck where repl 0 _ = [] repl n val = let res = convert $ move val in if res == ' ' then repl n (move val) else res : (repl (n-1) (move val)) toLetter :: Card -> Char toLetter JokerA = ' ' toLetter JokerB = ' ' toLetter card = (cycle alphabet !!) $ getValue card - 1 convert :: [Card] -> Char convert (x:xs) = toLetter $ (x:xs) !! getValue x -- Moves the deck one step ahead move :: [Card] -> [Card] move cards = stepFour $ stepThree $ stepTwo $ stepOne cards where findStart :: (Eq a) => a -> [a] -> [a] findStart n (x:xs) = if x == n then (x:xs) else findStart n (xs ++ [x]) stepOne, stepTwo, stepThree, stepFour :: [Card] -> [Card] stepOne (JokerA:x:xs) = x:JokerA:xs stepOne (x:xs) = let change (x:y:xs) = if x == JokerA then (y:x:xs) else change ((y:xs) ++ [x]) in findStart x $ change (x:xs) stepTwo (JokerB:x:y:xs) = x:y:JokerB:xs stepTwo (x:xs) = let change (x:y:z:xs) = if x == JokerB then (y:z:x:xs) else change ((y:z:xs) ++ [x]) in findStart x $ change (x:xs) stepThree (x:xs) = let fn c = c /= JokerA && c /= JokerB toFirst = takeWhile fn (x:xs) toLast = reverse $ takeWhile fn $ reverse (x:xs) in toLast ++ (reverse (drop (length toLast) (reverse (drop (length toFirst) (x:xs))))) ++ toFirst stepFour cards = let l = last cards r = getValue l in drop r (init cards) ++ take r (cards) ++ [l]