Haskell Quiz/The Solitaire Cipher/Solution Stoltze
Jump to navigation
Jump to search
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 = unwords $ 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]