Haskell Quiz/The Solitaire Cipher/Solution Burton
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 Char
import List
import Maybe
import Foreign
import Random
{--
*Main> decrypt newdeck $ encrypt newdeck "haskell is miles better!"
"HASKE LLISM ILESB ETTER"
*Main> let d = shuffledeck
*Main> decrypt d $ encrypt d "haskell is miles better!"
"HASKE LLISM ILESB ETTER"
*Main>
--}
data FaceValue = Ace | F2 | F3 | F4 | F5 | F6 | F7 | F8 | F9 | F10 | Jack | Queen | King
deriving (Show, Eq, Enum)
data Suit = Clubs | Spades | Diamonds | Hearts deriving (Show, Eq, Enum)
data Card = Card Suit FaceValue | JokerA | JokerB
deriving (Show, Eq)
type Deck = [Card]
--cardval - clubs are face value, diamonds plus 13, and so on - Jokers are both 53
cardval :: Card -> Int
cardval (Card Clubs v) = fromEnum v + 1
cardval (Card Diamonds v) = fromEnum v + 14
cardval (Card Hearts v) = fromEnum v + 27
cardval (Card Spades v) = fromEnum v + 40
cardval _ = 53 -- Jokers
isJoker :: Card -> Bool
isJoker c = c == JokerA || c== JokerB
--take a card to a letter
card2char :: Card -> Char
card2char c = int2alpha $ cardval c `mod` 26
--take a letter to int, A=1, Z=26
char2int :: Char -> Int
char2int = (64 `subtract`) . (ord)
--take a letter to int, 1=A, Z=26
int2alpha :: Int -> Char
int2alpha = (chr) . (+64)
splitAtMb n [] = Nothing
splitAtMb n l = Just $ splitAt n l
in_fives l = trim $ concat $ intersperse " " $ unfoldr (splitAtMb 5)
(l ++ replicate n 'X')
where n = if m5 == 0 then 0 else 5 - m5
m5 = length l `mod` 5
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
--get an ordered deck
newdeck :: Deck
newdeck = [Card s f | s <- [Clubs .. Hearts], f <- [Ace .. King]] ++ JokerA : JokerB : []
--key the deck ready to provide a keystream
keydeck :: Deck -> Deck
keydeck = countcut. triplecut . (movedown JokerB) . (movedown JokerB) . (movedown JokerA)
--bump a card down by one place in a deck, treating the deck as circular so if the card is
-- last in the deck it becomes 2nd to front not 1st
movedown :: Eq a => a -> [a] -> [a]
movedown c d = if c == last d
then head d : c : init (tail d)
else top ++ c2 : c1 : rest
where (top, c1:c2:rest) = break (==c) d
--substitute the cards above the first joker for those below the 2nd one
triplecut :: Deck -> Deck
triplecut d = afterLastJoker d ++ center d ++ beforeFirstJoker d
where beforeFirstJoker = takeWhile (not . isJoker)
afterLastJoker = reverse . beforeFirstJoker . reverse
center = reverse . dropWhile (not . isJoker) . reverse . dropWhile (not . isJoker)
--get the value of the last card and move that many cards from the top of deck to above the last card
countcut :: Deck -> Deck
countcut d = init (drop n d) ++ take n d ++ [last d]
where n = cardval (last d)
--key the deck, read the value of the top card as n, add the nth card to stream, repeat
keystream :: Deck -> String
keystream d = if isJoker c then keystream d' else card2char c : keystream d'
where d' = keydeck d
c = d'!!(cardval $ d'!!0)
locate :: Eq a => a -> [a] -> Int
locate x xs = fromJust (elemIndex x xs)
clean :: String -> String
clean = map toUpper . filter isAlpha
encrypt, decrypt :: Deck -> String -> String
encrypt d = process (\x y -> max26 (x+y)) d
where max26 x = if x > 26 then x-26 else x
decrypt d = process (\x y -> if x <= y then (x+26)-y else x-y) d
process :: (Int -> Int -> Int) -> Deck -> String -> String
process f d s = if null str1 then "" else in_fives $ map int2alpha $ zipWith f ints1 ints2
where str1 = trim $ clean s
str2 = take (length str1) (keystream d)
ints1 = map char2int str1
ints2 = map char2int str2
shuffledeck :: Deck
shuffledeck = shuff newdeck []
where shuff [] d' = d'
shuff [x] d' = x:d'
shuff d d' = if null top
then shuff (init rest) ((head rest):d')
else shuff ((init $ top) ++ rest) ((d!!n):d')
where n = getRandNum $ length d - 1
(top, rest) = splitAt n d
getRandNum :: Int -> Int
getRandNum n = unsafePerformIO $ getStdRandom $ randomR (0,n)