Haskell Quiz/The Solitaire Cipher/Solution Matthias
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 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"