Personal tools

User:Geraldus

From HaskellWiki

Revision as of 23:45, 6 January 2014 by Geraldus (Talk | contribs)

(diff) ← Older revision | Latest revision (diff) | Newer revision → (diff)
Jump to: navigation, search


module Main where
 
import Data.Char (chr, toUpper, ord)
import Data.List (elemIndex, intersperse, findIndices)
import Data.Maybe (fromJust, isNothing)
 
data Suit = Clubs | Diamonds | Hearts | Spades
          deriving(Eq, Ord, Enum, Show)
 
 
data Rank = Ace | Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Knave | Queen | King
          deriving (Eq, Ord, Enum, Show)
 
 
data Card = NormalCard Rank Suit
          | JokerA
          | JokerB
    deriving (Eq, Ord, Show)
 
 
type Cards = [Card]
 
 
isJoker (NormalCard r s) = False
isJoker _ = True
 
cardVal :: Card -> Int
cardVal (NormalCard r s) = rankVal r + suitVal s
    where rankVal = (1+) . fromEnum
          suitVal = (*13) . fromEnum
cardVal _ = 53 -- For case of any Joker
 
-- Letter (Char) from card value
cardLtr c = ltrFromEnum v
    where v = 1 + mod (cardVal c - 1) 26
 
ltrFromEnum n = chr $ 64 + n
 
unkeydDeck :: Cards
unkeydDeck = allNormals ++ [JokerA, JokerB]
    where allNormals = [NormalCard r s | s <- [(Clubs)..], r <-[(Ace)..]]
 
{-
showDeck :: Cards -> String
showDeck = unwords . map showCard
    where showCard JokerA = "A"
          showCard JokerB = "B"
          showCard c = show $ cardVal c
-}
 
-- Splits deck at some card into two parts excluding the card itself.
splitAtCard :: Cards -> Card -> (Cards, Cards)
splitAtCard deck c
    | isNothing ci = (deck, [])
    | otherwise =
        let (bc, ac') = splitAt (fromJust ci) deck
            ac = drop 1 ac' in
                (bc, ac)
    where ci = elemIndex c deck
 
-- Moves card at some position in the deck right (to bottom) by some offset.
-- Deck is circular.
moveCardAt :: Int -> Int -> Cards -> Cards
moveCardAt _ _ [] = []
moveCardAt _ 0 d = d
moveCardAt pos offset deck
    | shift > lRgt = moveCardAt 0 (shift - lRgt) $ mvCrd : lft ++ rgt
    | otherwise = lft ++ take shift rgt ++ (mvCrd:drop shift rgt)
    where shift = offset `mod` lDck
          lDck = length deck
          lRgt = length rgt
          rlPos = pos `mod` lDck
          mvCrd = deck!!rlPos
          (lft, rgt) = splitAtCard deck mvCrd
 
-- Moves some card, if it present in the deck.
moveCard crd n dck
    | isNothing pos = dck
    | otherwise = moveCardAt (fromJust pos) n dck
    where pos = crd `elemIndex` dck
 
-- First step
moveRightJA = moveCard JokerA 1
 
-- Second step
moveRightJB = moveCard JokerB 2
 
tripleCut deck
    | length ids /= 2 = deck
    | otherwise = splR ++ mid ++ splL
    where ids = findIndices isJoker deck
          (splL, rst) = splitAt iFst deck
          (mid, splR) = splitAt iSnd rst
          iFst = head ids
          iSnd = last ids - iFst + 1
 
countCut deck = init (drop n deck) ++ take n deck ++ [lastCard]
    where lastCard = last deck
          n = cardVal lastCard
 
getKey :: Cards -> Maybe Char
getKey deck
    | isJoker crd = Nothing
    | otherwise = Just $ cardLtr crd
    where crd = deck !! cardVal (head deck)
 
-- Generates infinite keystream from some deck
keystream deck
    | isNothing key = keystream d'
    | otherwise = (\ (Just c) -> c) key : keystream d'
    where d' = countCut $ tripleCut $ moveRightJB $ moveRightJA deck
          key = getKey d'
 
 
cleanIn :: String -> String
cleanIn = map toUpper . filterLetters
    where filterLetters = filter isLetter
          isLetter c = c `elem` ['A'..'Z'] ++ ['a'..'z']
 
appendXs :: String -> String
appendXs str = str ++ replicate n 'X'
    where n = if m == 0 then m else 5 - m
          m = length str `mod` 5
 
splitBy :: Int -> [a] -> [[a]]
splitBy _ [] = []
splitBy n lst = take n lst: splitBy n rest
    where rest = drop n lst
 
bakeIn :: String -> [String]
bakeIn = splitBy 5 . appendXs . cleanIn
 
convertToInts :: [String] -> [[Int]]
convertToInts = map $ map (\ c -> ord c - 64)
 
makeIntPairs = zipWith zip
 
-- Encrypts sanitized message with some keystream.
-- Both message and keystream are represented as [[Int]].
-- Message and keystream are splitted in groups of 5 ints, where each number represents letter's alphabetic order number.
encrypt m k = encryptByIntLists $ makeIntPairs m k
    where encryptByIntLists = map encryptPairsList
          encryptPairsList = map encryptPair
          encryptPair (msgVal, keyVal) = ltrFromEnum $ 1 + (msgVal + keyVal - 1) `mod` 26
 
-- Decrypts message with some keystream.
decrypt e k = decryptByIntLists $ makeIntPairs e k
    where decryptByIntLists = map decryptPairsList
          decryptPairsList = map decryptPair
          decryptPair (encVal, keyVal) = ltrFromEnum $ 1 + (encVal + 25 - keyVal) `mod` 26
 
-- | The main entry point.
main :: IO ()
main = do
    let msg = "Haskell is Awesome!"
    let prp = bakeIn msg
    let keys = splitBy 5 $ take (5 * length prp) $ keystream unkeydDeck
    putStrLn $ "Prepared > " ++ show prp
    putStrLn $ "Keys     > " ++ show keys
 
    let msgInts = convertToInts prp
    let keyInts = convertToInts keys
    let encoded = encrypt msgInts keyInts
    let encInts = convertToInts encoded
 
    putStrLn "----------------------------------------------------"
    putStrLn $ "Encoded  > " ++ show encoded
    putStrLn $ "Decoded  > " ++ show (decrypt encInts keyInts)
    -- example from RubyQuiz
    putStrLn $ "Example  > " ++ show (decrypt (convertToInts (splitBy 5 "ABVAWLWZSYOORYKDUPVH")) keyInts)