Haskell Quiz/The Solitaire Cipher/Solution Stoltze
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.
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]