# Haskell Quiz/The Solitaire Cipher/Solution Igloo

### From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)

(sharpen cat) |
|||

Line 1: | Line 1: | ||

− | [[Category: | + | [[Category:Haskell Quiz solutions|Solitaire Cipher]] |

This implementation attempts to be short and beautiful rather than efficient. It's just the natural, pure solution, making use of lazy evaluation by generating an infinite key stream and then zipping that with the data. | This implementation attempts to be short and beautiful rather than efficient. It's just the natural, pure solution, making use of lazy evaluation by generating an infinite key stream and then zipping that with the data. |

## Latest revision as of 10:59, 13 January 2007

This implementation attempts to be short and beautiful rather than efficient. It's just the natural, pure solution, making use of lazy evaluation by generating an infinite key stream and then zipping that with the data.

import Data.Char import Data.List -- This handy function should be imported from Data.Maybe or somewhere, -- along with justWhen justUnless :: (a -> Bool) -> a -> Maybe a justUnless f x = if f x then Nothing else Just x -- Sanitisation, padding and splitting sanitise :: String -> String sanitise = map toUpper . filter isAlpha . filter isAscii pad :: Int -> String -> String pad n = concat . init . splitAts n . (++ replicate n 'X') splitAts :: Int -> [a] -> [[a]] splitAts n = unfoldr (fmap (splitAt n) . justUnless null) -- The deck initialKey :: [Int] initialKey = [1..54] isJokerA, isJokerB, isJoker :: Int -> Bool isJokerA = (== 53) isJokerB = (== 54) isJoker = (>= 53) toCount :: Int -> Int toCount = (`min` 53) -- Deck manipulation functions rollDown, rollDownTwice :: (a -> Bool) -> [a] -> [a] rollDown f xs = case break f xs of (y:ys, [x]) -> y : x : ys (ys, x:z:zs) -> ys ++ [z, x] ++ zs rollDownTwice f = rollDown f . rollDown f tripleCut :: [Int] -> [Int] tripleCut xs = case break isJoker xs of (xs1, y:xs') -> case break isJoker xs' of (xs2, z:xs3) -> xs3 ++ [y] ++ xs2 ++ [z] ++ xs1 countCut :: [Int] -> [Int] countCut xs = case splitAt 53 xs of (xs', [n]) -> case splitAt (toCount n) xs' of (ys, zs) -> zs ++ ys ++ [n] readVal :: [Int] -> Int readVal xs@(x:_) = xs !! (toCount x) -- Algorithm alg :: (Int -> Int -> Int) -> [Int] -> String -> String alg f key = concat . intersperse " " . splitAts 5 . zipWith (arith f) (mkStream key) arith :: (Int -> Int -> Int) -> Int -> Char -> Char arith f i = chr . (+ ord 'A') . (`mod` 26) . f i . subtract (ord 'A') . ord enc, dec :: String -> String enc = alg (+) initialKey . pad 5 . sanitise dec = alg subtract initialKey . filter (' ' /=) mkStream :: [Int] -> [Int] mkStream = filter (not . isJoker) . map readVal . tail . iterate step step :: [Int] -> [Int] step = countCut . tripleCut . rollDownTwice isJokerB . rollDown isJokerA