# Haskell Quiz/The Solitaire Cipher/Solution Matthias

### From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)

m |
|||

(6 intermediate revisions by 4 users not shown) | |||

Line 1: | Line 1: | ||

− | < | + | [[Category:Haskell Quiz solutions|Solitaire Cipher]] |

+ | |||

+ | <haskell> | ||

module Main where | module Main where | ||

− | import Maybe | + | import Data.Maybe |

− | import Monad | + | import Control.Monad |

− | import Char | + | import Data.Char |

− | import List | + | import Data.List |

import Control.Exception | import Control.Exception | ||

import Control.Monad.ST | import Control.Monad.ST | ||

Line 10: | Line 12: | ||

{- | {- | ||

− | + | carelessly written. i haven't looked much at the discussion or at the other | |

− | 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. | + | solutions, so there is certainly room for improvent, cleanup, and completion. |

− | + | also it would be nice to make it less than three billion times slower than | |

+ | a straight-forward C implementation (how much would it help merely to use | ||

+ | immutable arrays?) | ||

-} | -} | ||

Line 169: | Line 173: | ||

tripleCut d = c ++ b ++ a | tripleCut d = c ++ b ++ a | ||

where | where | ||

− | posA = fromJust $ | + | posA = fromJust $ elemIndex JokerA d |

− | posB = fromJust $ | + | posB = fromJust $ elemIndex JokerB d |

posTop = min posA posB | posTop = min posA posB | ||

Line 213: | Line 217: | ||

d <- readSTRef ref | d <- readSTRef ref | ||

writeSTRef ref $ keyDeck key d | writeSTRef ref $ keyDeck key d | ||

− | + | replicateM len $ streamStep ref) | |

testStream = stream 0 10 == "DWJXHYRFDG" | testStream = stream 0 10 == "DWJXHYRFDG" | ||

Line 236: | Line 240: | ||

test1 = "CLEPK HHNIY CFPWH FDFEH" | test1 = "CLEPK HHNIY CFPWH FDFEH" | ||

test2 = "ABVAW LWZSY OORYK DUPVH" | test2 = "ABVAW LWZSY OORYK DUPVH" | ||

− | </ | + | </haskell> |

## Latest revision as of 05:48, 21 February 2010

module Main where import Data.Maybe import Control.Monad import Data.Char import Data.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. also it would be nice to make it less than three billion times slower than a straight-forward C implementation (how much would it help merely to use immutable arrays?) -} ---------------------------------------------------------------------- -- 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 $ elemIndex JokerA d posB = fromJust $ elemIndex 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 replicateM 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"