Haskell Quiz/The Solitaire Cipher/Solution Matthias

module Main where
import Maybe
import Monad
import Char
import List
import Control.Exception
import Control.Monad.ST
import Data.STRef

{-

carelessly written.  i haven't looked much at the discussion or at the other
solutions, so there is certainly room for improvent, cleanup, and completion.

-}

----------------------------------------------------------------------
-- the deck

data Suit = Clubs | Diamonds | Hearts | Spades
  deriving (Eq, Ord, Read, Show)

instance Enum Suit where
    toEnum 0 = Clubs
    toEnum 1 = Diamonds
    toEnum 2 = Hearts
    toEnum 3 = Spades
    toEnum i = error ("enum Suit: " ++ show i)

    enumFrom x = map toEnum [fromEnum x .. 3]
    enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 3]

    fromEnum Clubs = 0
    fromEnum Diamonds = 1
    fromEnum Hearts = 2
    fromEnum Spades = 3

data Base = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King
  deriving (Eq, Ord, Read, Show)

instance Enum Base where
    toEnum 1 = Ace
    toEnum 2 = Two
    toEnum 3 = Three
    toEnum 4 = Four
    toEnum 5 = Five
    toEnum 6 = Six
    toEnum 7 = Seven
    toEnum 8 = Eight
    toEnum 9 = Nine
    toEnum 10 = Ten
    toEnum 11 = Jack
    toEnum 12 = Queen
    toEnum 13 = King
    toEnum i = error ("enum Base: " ++ show i)

    enumFrom x = map toEnum [fromEnum x .. 13]
    enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 13]

    fromEnum Ace = 1
    fromEnum Two = 2
    fromEnum Three = 3
    fromEnum Four = 4
    fromEnum Five = 5
    fromEnum Six = 6
    fromEnum Seven = 7
    fromEnum Eight = 8
    fromEnum Nine = 9
    fromEnum Ten = 10
    fromEnum Jack = 11
    fromEnum Queen = 12
    fromEnum King = 13

data Card = Card Base Suit | JokerA | JokerB
  deriving (Eq, Ord, Read, Show)

instance Enum Card where
    fromEnum JokerA = 53
    fromEnum JokerB = 53
    fromEnum (Card base suit) = fromEnum base + (fromEnum suit * 13)

    toEnum 53 = error "Jokers break instance Enum Card."
    toEnum i | i >= 1 && i <= 52 = Card (toEnum ((i - 1) `mod` 13 + 1)) (toEnum ((i - 1) `div` 13))
    toEnum i = error (show i)

    enumFrom x = map toEnum [fromEnum x .. 52] ++ [JokerA, JokerB]
    enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 52] ++ [JokerA, JokerB]

isJoker :: Card -> Bool
isJoker = (`elem` [JokerA, JokerB])

type Deck = [Card]

isDeck d = sort d == deck

deck :: [Card]
deck = [Card Ace Clubs ..]


----------------------------------------------------------------------
-- a few auxiliary transformations

cardToLetter :: Card -> Char
cardToLetter JokerA = error "cardToLetter: please don't convert jokers to letters."
cardToLetter JokerB = error "cardToLetter: please don't convert jokers to letters."
cardToLetter c = chr ((fromEnum c - 1) `mod` 26 + ord 'A')

letterToCard :: Char -> Card
letterToCard c
    | c <= 'A' || c >= 'Z' = error "letterToCard: only capitals [A-Z] can be converted into cards."
    | otherwise            = toEnum (ord c - ord 'A' + 1)

cleanupInput :: String -> [String]
cleanupInput = groupN 5 'X' . catMaybes . map f
    where
    f c | ord c >= ord 'A' && ord c <= ord 'Z' = Just c
        | ord c >= ord 'a' && ord c <= ord 'z' = Just $ toUpper c
        | otherwise                            = Nothing

    groupN :: Int -> a -> [a] -> [[a]]
    groupN n pad = f n
        where
        f 0 xs      = [] : f n xs
        f i (x:xs)  = let (l:ls) = f (i-1) xs in (x:l):ls
        f i []      = if i < n then [replicate i pad] else []

    intersperseNth :: Int -> a -> [a] -> [a]  -- we don't need that any more now, but it's still a cool funktion.  (:
    intersperseNth n c = f n
        where
        f 0 xs      = c : f n xs
        f i (x:xs)  = x : f (i-1) xs
        f _ []      = []

newXOR :: Char -> Card -> Char
newXOR c o
     | c <= 'A' || c >= 'Z'       = error ("newXOR: illegal character: " ++ show c)
     | isJoker o                  = error ("newXOR: illegal card: " ++ show o)
     | otherwise                  = let
                                    c' = ord c - ord 'A'
                                    o' = fromEnum o - 1
                                    in chr ((c' + o') `mod` 26 + 1)

-- (It may also be interesting to write an instance of Num for Card, but let's see how far we get without one first...)


----------------------------------------------------------------------
-- the stream

-- circular moves: think of the deck as being a ring, not a list, and always move JokerA one card down, and JokerB two.

moveA :: Deck -> Deck
moveA = f []
    where
    f acc (JokerA : x : xs)      = reverse acc ++ (x : JokerA : xs)
    f acc (JokerA : [])          = last acc : JokerA : tail (reverse acc)
    f acc (x : xs)               = f (x : acc) xs

moveB :: Deck -> Deck
moveB = f []
    where
    f acc (JokerB : x : y : ys)  = reverse acc ++ (x : y : JokerB : ys)
    f acc (JokerB : x : [])      = last acc : JokerB : tail (reverse (x : acc))
    f acc (JokerB : [])          = case reverse acc of (a : b : ccc) -> a : b : JokerB : ccc
    f acc (x : xs)               = f (x : acc) xs

-- first triple cut: split at jokers and shuffle triples

tripleCut :: Deck -> Deck
tripleCut d = c ++ b ++ a
    where
    posA = fromJust $ findIndex (== JokerA) d
    posB = fromJust $ findIndex (== JokerB) d

    posTop = min posA posB
    posBot = max posA posB

    -- d == a ++ b@([Joker] ++ _ ++ [Joker]) ++ c

    a = take posTop d
    x = drop posTop d
    b = take (posBot - posTop + 1) x
    c = drop (posBot - posTop + 1) x

--  triple cut

countCut :: Deck -> Deck
countCut d = lower ++ upper ++ [c]
    where
    c = last d
    (upper, lower) = splitAt (fromEnum c) (init d)

-- extract the next stream symbol

findSymbol :: Deck -> Card
findSymbol d = d !! (fromEnum (head d))

streamStep :: STRef s Deck -> ST s Char
streamStep ref = do
                 d <- readSTRef ref
                 let d' = countCut . tripleCut . moveB . moveA $ d
                 writeSTRef ref d'
                 let s = findSymbol d'
                 if isJoker s
                    then streamStep ref
                    else return $ cardToLetter s

streamStart :: ST s (STRef s Deck)
streamStart = newSTRef deck

stream :: Integer -> Int -> String
stream key len = runST (do
                     ref <- streamStart
                     d <- readSTRef ref
                     writeSTRef ref $ keyDeck key d
                     sequence . replicate len $ streamStep ref)

testStream = stream 0 10 == "DWJXHYRFDG"


----------------------------------------------------------------------
-- the algorithm frame

-- and this is where i got bored...  (-:


----------------------------------------------------------------------
-- keying the deck

keyDeck :: Integer -> Deck -> Deck
keyDeck _ d = d  -- (not yet)


----------------------------------------------------------------------
-- testing

test1 = "CLEPK HHNIY CFPWH FDFEH"
test2 = "ABVAW LWZSY OORYK DUPVH"