[Haskell-cafe] Solitaire cipher

[jim burton]

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 (Spades i)   = i+39
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
through in haskell?
                      (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
Sent from the Haskell - Haskell-Cafe mailing list archive at Nabble.com.