Difference between revisions of "Haskell Quiz/The Solitaire Cipher/Solution Matthias"
From HaskellWiki
m 
m 

(5 intermediate revisions by 4 users not shown)  
Line 1:  Line 1:  
−  <pre> 

+  [[Category:Haskell Quiz solutionsSolitaire 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 straightforward C implementation (how much would it help merely to use 

+  immutable arrays?) 

} 
} 

Line 170:  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 214:  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 237:  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 straightforward 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 [AZ] 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 (i1) 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 (i1) 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"