Haskell Quiz/The Solitaire Cipher/Solution Tirpen
Jump to navigation
Jump to search
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)