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
-- | Haskell solution to www.rubyquiz.com/quiz1.html | |
module Solitaire where | |
import Data.Char (isAlpha, isSpace, toUpper, ord, chr) | |
import Data.List (unfoldr, elemIndex, dropWhileEnd) | |
import Data.Maybe (catMaybes) | |
data Suit = Clubs | |
| Diamonds | |
| Hearts | |
| Spades | |
deriving (Eq) | |
data Value = Ace | |
| Two | |
| Three | |
| Four | |
| Five | |
| Six | |
| Seven | |
| Eight | |
| Nine | |
| Ten | |
| Jack | |
| Queen | |
| King | |
deriving (Eq) | |
data Card = Card Value Suit | |
| Joker Char | |
deriving (Eq) | |
type StrMessage = [[Char]] | |
type NumMessage = [[Int]] | |
type Deck = [Card] | |
-- {{{ unkeyedDeck | |
unkeyedDeck :: Deck | |
unkeyedDeck = [ Card Ace Clubs | |
, Card Two Clubs | |
, Card Three Clubs | |
, Card Four Clubs | |
, Card Five Clubs | |
, Card Six Clubs | |
, Card Seven Clubs | |
, Card Eight Clubs | |
, Card Nine Clubs | |
, Card Ten Clubs | |
, Card Jack Clubs | |
, Card Queen Clubs | |
, Card King Clubs | |
, Card Ace Diamonds | |
, Card Two Diamonds | |
, Card Three Diamonds | |
, Card Four Diamonds | |
, Card Five Diamonds | |
, Card Six Diamonds | |
, Card Seven Diamonds | |
, Card Eight Diamonds | |
, Card Nine Diamonds | |
, Card Ten Diamonds | |
, Card Jack Diamonds | |
, Card Queen Diamonds | |
, Card King Diamonds | |
, Card Ace Hearts | |
, Card Two Hearts | |
, Card Three Hearts | |
, Card Four Hearts | |
, Card Five Hearts | |
, Card Six Hearts | |
, Card Seven Hearts | |
, Card Eight Hearts | |
, Card Nine Hearts | |
, Card Ten Hearts | |
, Card Jack Hearts | |
, Card Queen Hearts | |
, Card King Hearts | |
, Card Ace Spades | |
, Card Two Spades | |
, Card Three Spades | |
, Card Four Spades | |
, Card Five Spades | |
, Card Six Spades | |
, Card Seven Spades | |
, Card Eight Spades | |
, Card Nine Spades | |
, Card Ten Spades | |
, Card Jack Spades | |
, Card Queen Spades | |
, Card King Spades | |
, Joker 'A' | |
, Joker 'B' | |
] | |
-- }}} | |
-- | Constant: group size | |
groupSize :: Int | |
groupSize = 5 | |
-- | Constant: suit modifier | |
suitModifier :: Suit -> Int | |
suitModifier Clubs = 0 | |
suitModifier Diamonds = 13 | |
suitModifier Hearts = 26 | |
suitModifier Spades = 39 | |
-- | Get the value of a card | |
cardValue :: Card -> Int | |
cardValue (Card Ace suit) = 1 + suitModifier suit | |
cardValue (Card Two suit) = 2 + suitModifier suit | |
cardValue (Card Three suit) = 3 + suitModifier suit | |
cardValue (Card Four suit) = 4 + suitModifier suit | |
cardValue (Card Five suit) = 5 + suitModifier suit | |
cardValue (Card Six suit) = 6 + suitModifier suit | |
cardValue (Card Seven suit) = 7 + suitModifier suit | |
cardValue (Card Eight suit) = 8 + suitModifier suit | |
cardValue (Card Nine suit) = 9 + suitModifier suit | |
cardValue (Card Ten suit) = 10 + suitModifier suit | |
cardValue (Card Jack suit) = 11 + suitModifier suit | |
cardValue (Card Queen suit) = 12 + suitModifier suit | |
cardValue (Card King suit) = 13 + suitModifier suit | |
cardValue (Joker _) = 53 | |
-- | Returns True if the card is not a joker | |
notJoker :: Card -> Bool | |
notJoker (Joker _) = False | |
notJoker _ = True | |
-- | Move the A joker down one card and the B joker down two | |
shiftJokers :: Deck -> Deck | |
shiftJokers = move (Joker 'B') 2 | |
. move (Joker 'A') 1 | |
-- | Perform a triple cut | |
tripleCut :: Deck -> Deck | |
tripleCut deck = bottom ++ middle ++ top | |
where top = takeWhile notJoker deck | |
bottom = reverse $ takeWhile notJoker $ reverse deck | |
middle = dropWhile notJoker . dropWhileEnd notJoker $ deck | |
-- | Perform a count cut | |
countCut :: Deck -> Deck | |
countCut deck = drop value (init deck) ++ cut ++ [last deck] | |
where value = cardValue $ last deck | |
cut = take value deck | |
-- | Get the output letter of the deck's current state | |
outputLetter :: Deck -> Maybe Char | |
outputLetter deck = if notJoker letterCard | |
then Just (toLetter $ (cardValue letterCard) - letterModifier) | |
else Nothing | |
where value = cardValue $ head deck | |
letterCard = deck !! value | |
letterModifier = case letterCard of (Card _ Clubs) -> 0 | |
(Card _ Diamonds) -> 0 | |
(Card _ Hearts) -> 26 | |
(Card _ Spades) -> 26 | |
-- | Circularly move an item in a list by a certain number of spots | |
move :: (Eq a) => a -> Int -> [a] -> [a] | |
move item by list = case (elemIndex item list) of | |
Nothing -> list | |
Just i -> let newIndex = constrain (1,length list) $ i + by | |
(before,after) = splitAt newIndex $ remove list i | |
in if newIndex >= (length list) then (head before):item:(tail before) | |
else before ++ [item] ++ after | |
-- | Remove an item from a list | |
remove :: [a] -> Int -> [a] | |
remove list i = pre ++ tail post | |
where (pre,post) = splitAt i list | |
-- | Circularly ensure that a value is within two boundaries | |
constrain :: (Int,Int) -> Int -> Int | |
constrain (min,max) x | |
| x < min = constrain (min,max) $ x + range | |
| x > max = constrain (min,max) $ x - range | |
| otherwise = x | |
where range = (max-min) + 1 | |
-- | Run Solitaire encryption | |
solitaire :: Deck -> Deck | |
solitaire = countCut . tripleCut . shiftJokers | |
-- | Get the state of the deck after a certain number of encryption steps, | |
-- with 0 being the unkeyed deck | |
deck :: Int -> Deck | |
deck x | x <= 0 = unkeyedDeck | |
| otherwise = solitaire $ deck (x-1) | |
-- | Convert a list into a list of lists of size n | |
splitEvery :: Int -> [a] -> [[a]] | |
splitEvery n = takeWhile (not.null) . (unfoldr $ Just . splitAt n) | |
-- | Discard any non A-Z characters, uppercase the remaining letters, | |
-- and split it into five-character groups, padding with X's if needed | |
messageLetters :: String -> StrMessage | |
messageLetters = splitEvery groupSize . xpad . map toUpper . filter isAlpha | |
-- | Get a certain number of letters from the keystream algorithm | |
keystreamLetters :: Int -> StrMessage | |
keystreamLetters n = splitEvery groupSize . take n . catMaybes $ | |
[ outputLetter $ deck x | x <- [1..]] | |
-- | Convert a grouped list of letters to numbers | |
toNumMessage :: StrMessage -> NumMessage | |
toNumMessage [] = [] | |
toNumMessage (x:xs) = (map toNumber x) : toNumMessage xs | |
-- | Convert a grouped list of numbers to letters | |
toStrMessage :: NumMessage -> StrMessage | |
toStrMessage [] = [] | |
toStrMessage (x:xs) = (map toLetter x) : toStrMessage xs | |
-- | Combine two number lists via addition | |
addMessages :: NumMessage -> NumMessage -> NumMessage | |
addMessages = zipWith (\x y -> zipWith circularPlus x y) | |
where circularPlus a b = let c = a + b in if c > 26 then c - 26 else c | |
-- | Combine two number lists via subtraction | |
subtractMessages :: NumMessage -> NumMessage -> NumMessage | |
subtractMessages = zipWith (\x y -> zipWith circularMinus x y) | |
where circularMinus a b = let c = a - b in if c < 1 then c + 26 else c | |
-- | Pad a string with X's until it divides evenly by groupSize | |
xpad :: String -> String | |
xpad str | remainder == 0 = str | |
| otherwise = xpad $ str ++ "X" | |
where remainder = length str `rem` groupSize | |
-- | Convert capital letters to their number equivalent, so A = 1, B = 2, etc. | |
toNumber :: Char -> Int | |
toNumber = subtract 64 . ord | |
-- | Convert numbers to their capital letter equivalent, so 1 = A, 2 = B, etc. | |
toLetter :: Int -> Char | |
toLetter = chr . (+ 64) | |
-- | Encrypt a message | |
encrypt :: String -> String | |
encrypt msg = unwords $ toStrMessage $ addMessages x y | |
where x = toNumMessage $ messageLetters msg | |
y = toNumMessage $ keystreamLetters (length msg) | |
-- | Decrypt a message | |
decrypt :: String -> String | |
decrypt msg = unwords $ toStrMessage $ subtractMessages x y | |
where x = toNumMessage $ words msg | |
y = toNumMessage $ keystreamLetters (length $ filter (not.isSpace) msg) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment