Haskell Quiz/The Solitaire Cipher/Solution Tirpen
< Haskell Quiz | The Solitaire Cipher
I used a slightly off-beat representation of a deck and choose to use Sequences instead of lists, since I do a lot of concats and poking around both ends of the seqs. I hope someones finds it interesting.
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)