# Difference between revisions of "Haskell Quiz/The Solitaire Cipher/Solution Igloo"

From HaskellWiki

(My solution) |
|||

Line 1: | Line 1: | ||

[[Category:Code]] |
[[Category:Code]] |
||

− | This implementation attempts to be 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. |

<haskell> |
<haskell> |

## Revision as of 14:58, 27 October 2006

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
```