Haskell Quiz/The Solitaire Cipher/Solution Burton

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)