# Haskell Quiz/The Solitaire Cipher/Solution Burton

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)

```module Main
where
import Char
import List
import Maybe
import Foreign
import Random
{--
*Main> decrypt newdeck \$ encrypt newdeck "haskell is miles better!"
*Main> let d = shuffledeck
*Main> decrypt d \$ encrypt d "haskell is miles better!"
*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 _                 = 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)
```