Created
September 4, 2011 09:00
-
-
Save kizzx2/1192551 to your computer and use it in GitHub Desktop.
Solitaire Cipher in Haskell
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Solitaire Cipher | |
-- http://www.rubyquiz.com/quiz1.html | |
module Solitaire where | |
import Data.Sequence ((><), (|>), (<|)) | |
import qualified Data.Sequence as S | |
import Debug.Trace | |
import Control.Arrow | |
import Data.Char | |
import Data.Maybe | |
import Data.List (unfoldr) | |
alternates = x | |
where x = 0 : y | |
y = 1 : x | |
(!) = S.index | |
data Card = Card Int | JokerA | JokerB deriving (Eq, Show) | |
type Deck = S.Seq Card | |
fred = S.fromList $ map Card [1..52] ++ [JokerA, JokerB] | |
remove :: Int -> Deck -> Deck | |
remove i deck = partA >< partB | |
where | |
parts = S.splitAt i deck | |
partA = fst parts | |
partB = S.drop 1 . snd $ parts | |
insert :: Int -> Card -> Deck -> Deck | |
insert i card deck = (partA |> card) >< partB | |
where | |
parts = S.splitAt i deck | |
partA = fst parts | |
partB = snd $ parts | |
swap :: Deck -> Int -> Int -> Deck | |
swap deck m n = S.update m (deck ! n) . S.update n (deck ! m) $ deck | |
moveDown :: Card -> Int -> Deck -> Deck | |
moveDown card n deck = deck' | |
where | |
size = S.length deck | |
deck' = go (S.findIndexL (==card) deck) | |
go (Just i) = | |
let j = if i + n >= size | |
then (i + n) `mod` (size-1) | |
else i + n | |
in remove i >>> insert (j) card $ deck | |
tripleCut :: Deck -> Deck | |
tripleCut deck = | |
(partC |> (deck ! topJoker)) >< (partB |> (deck ! bottomJoker)) >< partA | |
where | |
Just ia = S.findIndexL (==JokerA) deck | |
Just ib = S.findIndexL (==JokerB) deck | |
topJoker = min ia ib | |
bottomJoker = max ia ib | |
partA = S.take topJoker deck | |
partB = S.take (abs (ia-ib) - 1) . S.drop (topJoker + 1) $ deck | |
partC = S.drop (bottomJoker+1) deck | |
countCut :: Deck -> Deck | |
countCut deck = (partB' >< partA) |> bottom | |
where | |
bottom = deck ! (S.length deck - 1) | |
value = case bottom of | |
Card n -> n | |
JokerA -> 27 | |
JokerB -> 27 | |
partA = S.take value deck | |
partB = S.drop value deck | |
partB' = S.take (S.length partB - 1) partB | |
takeValue :: Deck -> Maybe Int | |
takeValue deck = output | |
where | |
value = case deck ! 0 of | |
(Card n ) -> n | |
JokerA -> 53 | |
JokerB -> 53 | |
output = case deck ! value of | |
(Card n) -> Just n | |
JokerA -> Nothing | |
JokerB -> Nothing | |
-- key :: Deck -> (Deck, Maybe Int) | |
key = (moveDown JokerA 1) >>> (moveDown JokerB 2) >>> tripleCut >>> countCut >>> (takeValue &&& id) | |
stream = unfoldr (Just . key) | |
toChar n = chr $ ord 'A' + ((n - 1) `mod` 26) | |
toNumber c = ord c - ord 'A' + 1 | |
keystream = map (toChar . fromJust) . filter (/=Nothing) . stream | |
chunksOf :: Int -> [a] -> [[a]] | |
chunksOf n = go [] | |
where | |
go acc [] = reverse acc | |
go acc xs | length xs <= n = go (xs:acc) [] | |
| otherwise = go (take n xs : acc) (drop n xs) | |
encrypt input = result | |
where | |
numbers = map toNumber . prepare $ input | |
keys = map toNumber (keystream fred) | |
crypt = zipWith (\x y -> (x + y) `mod`26) numbers keys | |
result = map toChar crypt | |
decrypt input = result | |
where | |
numbers = map toNumber $ input | |
keys = map toNumber (keystream fred) | |
crypt = zipWith (\x y -> (x - y) `mod`26) numbers keys | |
result = map toChar crypt | |
prepare :: String -> String | |
prepare msg = padded | |
where | |
n = 5 - ((length converted) `rem` 5) | |
padded = converted ++ replicate (if n < 5 then n else 0) 'X' | |
converted = map toUpper . filter isLetter $ msg |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment