Personal tools

Haskell Quiz/The Solitaire Cipher/Solution Matthias

From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)
Jump to: navigation, search
m
 
(3 intermediate revisions by 3 users not shown)
Line 1: Line 1:
  +
[[Category:Haskell Quiz solutions|Solitaire Cipher]]
  +
 
<haskell>
 
<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 171: Line 173:
 
tripleCut d = c ++ b ++ a
 
tripleCut d = c ++ b ++ a
 
where
 
where
posA = fromJust $ findIndex (== JokerA) d
+
posA = fromJust $ elemIndex JokerA d
posB = fromJust $ findIndex (== JokerB) d
+
posB = fromJust $ elemIndex JokerB d
   
 
posTop = min posA posB
 
posTop = min posA posB
Line 215: Line 217:
 
d <- readSTRef ref
 
d <- readSTRef ref
 
writeSTRef ref $ keyDeck key d
 
writeSTRef ref $ keyDeck key d
sequence . replicate len $ streamStep ref)
+
replicateM len $ streamStep ref)
   
 
testStream = stream 0 10 == "DWJXHYRFDG"
 
testStream = stream 0 10 == "DWJXHYRFDG"

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"