Personal tools

Haskell Quiz/The Solitaire Cipher/Solution Igloo

From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)
Jump to: navigation, search
(sharpen cat)
 
Line 1: Line 1:
[[Category:Code]]
+
[[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