Haskell Quiz/The Solitaire Cipher/Solution Tirpen
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
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)