Haskell Quiz/The Solitaire Cipher/Solution Tirpen

module Solitaire where
 
import Data.Sequence as S
import Control.Monad.State
import Data.Char(chr)
 
data Card = Card Int | A | B deriving (Eq, Show)
 
isJoker :: Card -> Bool
isJoker (Card _)= False
isJoker _ = True
 
value :: Card -> Int
value (Card i) = i
value _ = 53
 
type Deck = (Seq (Card), Card, Seq (Card), Card, Seq (Card))
 
 
bottomCard :: Deck -> Card
bottomCard (_,_,_,j,s3) = case (viewr s3) of
                         EmptyR -> j
                         (s :> c) -> c
 
-- Converting between Deck and (Seq Card)
toSeq :: Deck -> Seq Card
toSeq (s1,j1,s2,j2,s3) = s1 >< (singleton j1) >< s2 >< (singleton j2) >< s3
 
fromSeq :: Seq Card -> Deck
fromSeq s = let
              (s1,rest1) = noJoke s
              (j1 :< rest2) = viewl rest1
              (s2,rest3) = noJoke rest2
              (j2 :< rest4) = viewl rest3
              s3 = rest4
            in
              (s1,j1,s2,j2,s3)
  where
    noJoke sq = noJoke' (viewl sq)
    noJoke' (c :< cs) = if (isJoker c) 
                          then (empty,(c <| cs))
                          else let (a,b) = noJoke' $ viewl cs
                               in (c <| a,b)
    noJoke' EmptyL = (empty, empty)
 
 
moveA, moveB  :: Deck -> Deck
moveA d@(s1, A, s2, B, s3) = moveFst d
moveA d@(s1, B, s2, A, s3) = moveSnd d
moveB d@(s1, B, s2, A, s3) = moveFst d
moveB d@(s1, A, s2, B, s3) = moveSnd d
 
--Moves the topmost joker down one step.
moveFst    :: Deck -> Deck
moveFst (s1, j1, s2, j2, s3) = case (viewl s2) of
                                 EmptyL -> (s1,j2,empty,j1,s3)
                                 (c :< s) -> (s1 |> c, j1, s, j2, s3)
--Moves the bottom joker down one step, possibly wrapping if it's the last card.
moveSnd    :: Deck -> Deck
moveSnd (s1, j1, s2, j2, s3) = case (viewl s3) of
                                 (c :< s) -> (s1 , j1, s2 |> c, j2, s)
                                 --If j2 is the last card, place it _under_ the top card
                                 EmptyL -> case (viewl s1) of
                                             (c :< s) -> (singleton c, j2, s, j1, s2)
                                             --Odd case, We start with (<>,j1,s2,j2,<>)
                                             EmptyL -> (empty, j1, empty, j2, s2)
 
--Switches the stuff above the top joker with the stuff below the bottom one.
trippleCut :: Deck -> Deck
trippleCut (s1,j1,s2,j2,s3) = (s3,j1,s2,j2,s1)
 
 
 
-- Looks at bottom card, remove that many from the top and place them just
-- above the last card.
takeTop :: Deck -> Deck
takeTop d = let botc = bottomCard d :: Card
                num = (value botc) :: Int
                (lst :> _) = viewr $ toSeq d
            in fromSeq $ ((S.drop num lst) >< (S.take num lst)) |> botc
 
--Looks at top card, counts down that many card and returns the value of that card.
getValue :: Deck -> Int
getValue d = let (top :< rest) = viewl $ toSeq d
                 num = (value top) :: Int
             in (value $ index rest (num - 1))
 
 
oneStep :: State Deck Int
oneStep = State $ \d -> let d2 = takeTop . trippleCut . moveB . moveB . moveA $ d
                        in (getValue d2, d2)
 
keyStream :: Deck -> [Int]
keyStream d = let (a,_) = runState (sequence (repeat oneStep)) testdeck
              in filter (/= 53) a
 
encrypt :: String -> [Int] -> String
encrypt code keys = zipWith modChar code keys
 where
  charVal c = (fromEnum c) - 96
  valToChar i = chr (96 + i)
  modChar :: Char -> Int -> Char
  modChar c i = valToChar $ (charVal c + i) `mod` 26
 
decrypt :: String -> [Int] -> String
decrypt code keys = zipWith modChar code keys
 where
  charVal c = (fromEnum c) - 96
  valToChar i = chr (96 + i)
  modChar :: Char -> Int -> Char
  modChar c i = valToChar $ (260 + charVal c - i) `mod` 26
 
--The example from Rubyquiz
testCrypt = "clepkhhniycfpwhfdfeh"
testMess = "yourcipherisworkingx"
-- "unkeyed" deck
testdeck = fromSeq $ fromList $ (map Card [1..52]) ++ [A,B]
 
main = print $ decrypt testCrypt  (keyStream testdeck)