Haskell Quiz/The Solitaire Cipher/Solution Stoltze

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]