Skip to content

Instantly share code, notes, and snippets.

@dradtke
Last active December 15, 2015 00:09
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save dradtke/5171145 to your computer and use it in GitHub Desktop.
-- | 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