public
Last active

  • Download Gist
Solitaire.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250
-- | 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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.