jim burton jim at sdf-eu.org
Tue Oct 24 07:31:40 EDT 2006

```I'm a beginner having a go at implementing the Solitaire cipher
(http://www.rubyquiz.com/quiz1.html as mentioned in another post) and I'd be
really grateful if you could help me improve the code to be neater & use
more functions from the Prelude etc, or errors (eg at the moment I can't
work out why padding accumulates after encrypting, decrypting?)...Thanks.

*Main> decrypt \$ encrypt "haskell is better by miles"
"HASKE LLISB ETTER BYMIL ESAYP XXXXX "
*Main> decrypt \$ encrypt \$ decrypt \$ encrypt "haskell is better by miles"
"HASKE LLISB ETTER BYMIL ESAYP XXXXX BFCRK XXXXX "
*Main>
-------------------------------------------

import Char
import Random
import List
import Foreign
import Maybe

data Card = Clubs Int | Spades Int | Diamonds Int | Hearts Int | JokerA |
JokerB
deriving (Show, Eq)
type Deck = [Card]
--cardval - clubs are face value, diamonds plus 13, and so on - Jokers are
both 53
cardval              :: Card -> Int
cardval (Clubs i)    = i
cardval (Diamonds i) = i+13
cardval (Hearts i)   = i+26
cardval _            = 53

isJoker        :: Card -> Bool
isJoker JokerA = True
isJoker JokerB = True
isJoker _      = False
--take a card to a letter
card2char :: Card -> Char
card2char c = case c of
(Clubs i)    -> int2alpha \$ cardval c --can case fall
(Diamonds i) -> int2alpha \$ cardval c
(Hearts i)   -> int2alpha \$ (cardval c-26)
(Spades i)   -> int2alpha \$ (cardval c-26)
_            -> error ("Can't make " ++ show c ++
"into alpha")
--take a letter to int, A=1, Z=26
char2int :: Char -> Int
char2int = (64 `subtract`) . (ord)
--take a letter to int, 1=A, Z=26
int2alpha :: Int -> Char
int2alpha = (chr) . (+64)

splitAtMb n l = let p = splitAt n l
in if null \$ fst p
then Nothing
else Just p

in_fives l = foldr (\x y -> x++" "++y) [] \$ unfoldr (splitAtMb 5)
(l ++ replicate (5 - length l `mod` 5) 'X')

--get an ordered deck
newdeck :: Deck
newdeck = suit 'c' ++ suit 'd' ++ suit 'h' ++ suit 's' ++ JokerA : JokerB :
[]
where suit s = case s of
'c' -> [Clubs i | i <- [1..13]]
's' -> [Spades i | i <- [1..13]]
'd' -> [Diamonds i | i <- [1..13]]
'h' -> [Hearts i | i <- [1..13]]

--key the deck ready to provide a keystream - move JokerA down one place,
--JokerB down 2 places, perform a triplecut then a countcut
keydeck :: Deck -> Deck
keydeck = countcut. triplecut . (movedown JokerB) . (movedown JokerB) .
(movedown JokerA)

--bump a card down by one place in a deck, treating the deck as circular so
if the card is
-- last in the deck it becomes 2nd to front not 1st
movedown     :: Eq a => a -> [a] -> [a]
movedown c d = if c == last d
then head d : c : init (tail d)
else top ++ bot!!1 : c : (tail (tail bot))
where splt = splitAt (locate c d) d
top = fst splt
bot = snd splt
--substitute the cards above the first joker for those below the 2nd one
triplecut :: Deck -> Deck
triplecut d = afterLastJoker d ++ center d ++ beforeFirstJoker d
where beforeFirstJoker = takeWhile (not . isJoker)
afterLastJoker = reverse . beforeFirstJoker . reverse
center = reverse . dropWhile (not . isJoker) . reverse .
dropWhile (not . isJoker)

--get the value of the last card and move that many cards from the top of
deck to above the last card
countcut :: Deck -> Deck
countcut d = init (drop n d) ++ take n d ++ [last d]
where n = cardval (last d)

--key the deck, read the value of the top card as n, add the nth card to
stream, repeat
keystream :: Deck -> String
keystream d = if isJoker c then keystream d' else card2char c : keystream d'
where d' = keydeck d
c  = d'!!(cardval \$ d'!!0)

locate :: Eq a => a -> [a] -> Int
locate x xs = fromJust (elemIndex x xs)

clean :: String -> String
clean = map toUpper . filter isAlpha

encrypt, decrypt :: String -> String
--encrypt a string using an unshuffled deck to start
encrypt = process (\x y -> max26 (x+y))
where max26 x = if x > 26 then x-26 else x
--decrypt a string using an unshuffled deck to start
decrypt = process (\x y -> if x <= y then (x+26)-y else x-y)

process :: (Int -> Int -> Int) -> String -> String
process f s = in_fives \$ map int2alpha \$ zipWith f ints1 ints2
where str1  = clean s
str2  = take (length str1) (keystream newdeck)
ints1 = map char2int str1
ints2 = map char2int str2

--
View this message in context: http://www.nabble.com/Solitaire-cipher-tf2500700.html#a6971077