# Haskell Quiz/The Solitaire Cipher/Solution Matthias

(Difference between revisions)

```module Main where
import Maybe
import Char
import List
import Control.Exception
import Data.STRef

{-
carelessly written.  i haven't looked much at the discussion or at the other
solutions, so there is certainly room for improvent, cleanup, and completion.
also it would be nice to make it less than three billion times slower than
a straight-forward C implementation (how much would it help merely to use
immutable arrays?)
-}

----------------------------------------------------------------------
-- the deck

data Suit = Clubs | Diamonds | Hearts | Spades

instance Enum Suit where
toEnum 0 = Clubs
toEnum 1 = Diamonds
toEnum 2 = Hearts
toEnum i = error ("enum Suit: " ++ show i)

enumFrom x = map toEnum [fromEnum x .. 3]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 3]

data Base = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King

instance Enum Base where
toEnum 1 = Ace
toEnum 2 = Two
toEnum 3 = Three
toEnum 4 = Four
toEnum 5 = Five
toEnum 6 = Six
toEnum 7 = Seven
toEnum 8 = Eight
toEnum 9 = Nine
toEnum 10 = Ten
toEnum 11 = Jack
toEnum 12 = Queen
toEnum 13 = King
toEnum i = error ("enum Base: " ++ show i)

enumFrom x = map toEnum [fromEnum x .. 13]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 13]

data Card = Card Base Suit | JokerA | JokerB

instance Enum Card where

toEnum 53 = error "Jokers break instance Enum Card."
toEnum i | i >= 1 && i <= 52 = Card (toEnum ((i - 1) `mod` 13 + 1)) (toEnum ((i - 1) `div` 13))
toEnum i = error (show i)

enumFrom x = map toEnum [fromEnum x .. 52] ++ [JokerA, JokerB]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. 52] ++ [JokerA, JokerB]

isJoker :: Card -> Bool
isJoker = (`elem` [JokerA, JokerB])

type Deck = [Card]

isDeck d = sort d == deck

deck :: [Card]
deck = [Card Ace Clubs ..]

----------------------------------------------------------------------
-- a few auxiliary transformations

cardToLetter :: Card -> Char
cardToLetter JokerA = error "cardToLetter: please don't convert jokers to letters."
cardToLetter JokerB = error "cardToLetter: please don't convert jokers to letters."
cardToLetter c = chr ((fromEnum c - 1) `mod` 26 + ord 'A')

letterToCard :: Char -> Card
letterToCard c
| c <= 'A' || c >= 'Z' = error "letterToCard: only capitals [A-Z] can be converted into cards."
| otherwise            = toEnum (ord c - ord 'A' + 1)

cleanupInput :: String -> [String]
cleanupInput = groupN 5 'X' . catMaybes . map f
where
f c | ord c >= ord 'A' && ord c <= ord 'Z' = Just c
| ord c >= ord 'a' && ord c <= ord 'z' = Just \$ toUpper c
| otherwise                            = Nothing

groupN :: Int -> a -> [a] -> [[a]]
groupN n pad = f n
where
f 0 xs      = [] : f n xs
f i (x:xs)  = let (l:ls) = f (i-1) xs in (x:l):ls
f i []      = if i < n then [replicate i pad] else []

intersperseNth :: Int -> a -> [a] -> [a]  -- we don't need that any more now, but it's still a cool funktion.  (:
intersperseNth n c = f n
where
f 0 xs      = c : f n xs
f i (x:xs)  = x : f (i-1) xs
f _ []      = []

newXOR :: Char -> Card -> Char
newXOR c o
| c <= 'A' || c >= 'Z'       = error ("newXOR: illegal character: " ++ show c)
| isJoker o                  = error ("newXOR: illegal card: " ++ show o)
| otherwise                  = let
c' = ord c - ord 'A'
o' = fromEnum o - 1
in chr ((c' + o') `mod` 26 + 1)

-- (It may also be interesting to write an instance of Num for Card, but let's see how far we get without one first...)

----------------------------------------------------------------------
-- the stream

-- circular moves: think of the deck as being a ring, not a list, and always move JokerA one card down, and JokerB two.

moveA :: Deck -> Deck
moveA = f []
where
f acc (JokerA : x : xs)      = reverse acc ++ (x : JokerA : xs)
f acc (JokerA : [])          = last acc : JokerA : tail (reverse acc)
f acc (x : xs)               = f (x : acc) xs

moveB :: Deck -> Deck
moveB = f []
where
f acc (JokerB : x : y : ys)  = reverse acc ++ (x : y : JokerB : ys)
f acc (JokerB : x : [])      = last acc : JokerB : tail (reverse (x : acc))
f acc (JokerB : [])          = case reverse acc of (a : b : ccc) -> a : b : JokerB : ccc
f acc (x : xs)               = f (x : acc) xs

-- first triple cut: split at jokers and shuffle triples

tripleCut :: Deck -> Deck
tripleCut d = c ++ b ++ a
where
posA = fromJust \$ findIndex (== JokerA) d
posB = fromJust \$ findIndex (== JokerB) d

posTop = min posA posB
posBot = max posA posB

-- d == a ++ b@([Joker] ++ _ ++ [Joker]) ++ c

a = take posTop d
x = drop posTop d
b = take (posBot - posTop + 1) x
c = drop (posBot - posTop + 1) x

--  triple cut

countCut :: Deck -> Deck
countCut d = lower ++ upper ++ [c]
where
c = last d
(upper, lower) = splitAt (fromEnum c) (init d)

-- extract the next stream symbol

findSymbol :: Deck -> Card

streamStep :: STRef s Deck -> ST s Char
streamStep ref = do
let d' = countCut . tripleCut . moveB . moveA \$ d
writeSTRef ref d'
let s = findSymbol d'
if isJoker s
then streamStep ref
else return \$ cardToLetter s

streamStart :: ST s (STRef s Deck)
streamStart = newSTRef deck

stream :: Integer -> Int -> String
stream key len = runST (do
ref <- streamStart
writeSTRef ref \$ keyDeck key d
sequence . replicate len \$ streamStep ref)

testStream = stream 0 10 == "DWJXHYRFDG"

----------------------------------------------------------------------
-- the algorithm frame

-- and this is where i got bored...  (-:

----------------------------------------------------------------------
-- keying the deck

keyDeck :: Integer -> Deck -> Deck
keyDeck _ d = d  -- (not yet)

----------------------------------------------------------------------
-- testing

test1 = "CLEPK HHNIY CFPWH FDFEH"
test2 = "ABVAW LWZSY OORYK DUPVH"```