Programming Praxis – Steganography

In today’s Programming Praxis exercise, our goal is to implement a cipher that hides messages in spam emails. Let’s gets started, shall we?

Some imports:

import Control.Applicative
import Data.Bits
import Data.Char
import Data.List
import Data.List.Split (chunk)
import System.Random (randomRIO)

First we define the allowed characters (without numbers since they are treated a differently from the rest).

chars :: String
chars = ['A'..'Z'] ++ ['a'..'z'] ++ ". "

Neither the key nor the message can contain any other characters, so we make a function to remove all other characters.

sanitize :: String -> String
sanitize = flip intersect $ chars ++ ['0'..'9']

Making a key consists of removing duplicate characters, appending the rest and inserting the remaining numbers in their correct places.

makeKey :: String -> String
makeKey phrase = addDigits $ union (nub $ sanitize phrase) chars where
    addDigits = (=<<) (\c -> maybe [c] ((c:) . return) . lookup c $
                             filter (flip notElem phrase . snd) $
                             zip ('j':['a'..'i']) ['0'..'9'])

Next, we need a function to encode/decode the pairs of letters.

cipher :: (Int -> Int -> Int) -> String -> [String] -> String
cipher op key = (f =<<) where
    f ~[a,b] | c1 == c2  = [get (op r1 1) c1, get (op r2 1) c2]
             | r1 == r2  = [get r1 (op c1 1), get r2 (op c2 1)]
             | otherwise = [get r1 c2       , get r2 c1      ]
        where (r1,c1) = maybe (0,0) (`divMod` 8) $ elemIndex a key
              (r2,c2) = maybe (0,0) (`divMod` 8) $ elemIndex b key
              get r c = key !! (8 * mod r 8 + mod c 8)

The words are loaded from the given dictionary and divided into two lists based on whether their length is even or odd. For every bit of information a random word is selected from the appropriate list.

getWords :: FilePath -> [Bool] -> IO String
getWords dict bs = do
    (evens, odds) <- partition (even . length) . filter (\w -> all isAlpha w &&
                         length w < 9) . lines <$> readFile dict
    let pick xs = fmap (xs !!) $ randomRIO (0, length xs - 1)
    fmap unwords $ mapM (\b -> pick $ if b then odds else evens) bs

Hiding a message is a matter of doing all the required steps in the right order. Unlike the provided solution I used a 7-bit encoding since it saves me from having to make another lookup table.

hide :: FilePath -> String -> String -> IO String
hide dict key = getWords dict . (>>= \c -> map (testBit $ fromEnum c) [0..6]) .
                cipher (+) key . split . sanitize where
                    split [] = []
                    split (a:b:cs) | a /= b = [a,b  ] : split cs
                    split (a:cs) = [a,'X'] : split cs

To retrieve the original message we simply undo all the steps.

unhide :: String -> String -> String
unhide key = cipher (-) key . chunk 2 . map (toEnum .
                 foldr (flip setBit . fst) 0 . filter snd . zip [0..]) .
             chunk 7 . map (odd . length) . words

Some tests to see if everything is working properly:

main :: IO ()
main = do let key = makeKey "President Obama’s visit to a Chrysler plant in Tol\
                    \edo, Ohio, on Friday was the culmination of a campaign to \
                    \portray the auto bailouts as a brilliant success with no u\
                    \npleasant side effects."
          hidden <- hide "74550com.mon" key "Bonsai Code"
          putStrLn hidden
          print $ unhide key hidden == "Bonsai CodeX"

          let key2 = makeKey "a4b3c2"
          let msg2 = "abcd1234"
          print . (== msg2) . unhide key2 =<< hide "74550com.mon" key2 msg2

Yup. Make sure the recipient knows when you’re sending the message though, since it will undoubtedly get caught by the spam filter.

Programming Praxis – Chaocipher

In today’s Programming Praxis we have another cipher on our hands, called chaocipher. The provided Scheme solution is 25 lines, so let’s see if we can improve that.

Some imports:

import Control.Arrow
import Data.List

One of the steps of the algorithm is taking the first n characters and moving them to the end.

seek :: Int -> [a] -> [a]
seek to = uncurry (flip (++)) . splitAt to

Another step is taking a group of characters between two indices and applying the previous function to them. The Scheme solution combines these two functions in one, but I prefer to keep them separate.

shift :: Int -> Int -> [a] -> [a]
shift from to = (\((a,b),c) -> a ++ seek 1 b ++ c) .
                first (splitAt from) . splitAt to

With those two out of the way, ciphering in either direction is a matter of finding the input character on the appropriate wheel, outputting the corresponding character from the other wheel and repeating the process after modifying the wheels.

cipher :: Eq a => Bool -> [a] -> [a] -> [a] -> [a]
cipher _ _ _ []     = []
cipher e l r (x:xs) = to !! i : cipher e (shift 1 14 $ seek i l)
                      (shift 2 14 . shift 0 26 $ seek i r) xs
    where Just i = elemIndex x from
          (from, to) = if e then (r, l) else (l, r)

Let’s add some convenience functions for encoding and decoding:

encipher, decipher :: Eq a => [a] -> [a] -> [a] -> [a]
encipher = cipher True
decipher = cipher False

Of course we need to check if everything is working correctly:

main :: IO ()
main = do let l = "HXUCZVAMDSLKPEFJRIGTWOBNYQ"
              r = "PTLNBQDEOYSFAVZKGJRIHWXUMC"
              decoded = "WELLDONEISBETTERTHANWELLSAID"
              encoded = "OAHQHCNYNXTSZJRRHJBYHQKSOUJY"
          print $ encipher l r decoded == encoded
          print $ decipher l r encoded == decoded

Everything looks to be working alright, and at 10 lines we reduced the Scheme version by 60%. Not bad.

Programming Praxis – Straddling Checkerboard

In today’s Programming Praxis problem we have to implement the straddling checkerboard cipher. Let’s get started.

We’ll need two imports:

import Data.Char
import Data.List

Our alphabet for the checkerboard consists of letters and a space.

alphabet :: String
alphabet = ['A'..'Z'] ++ " "

The algorithm cannot deal with anything other than letters, numbers or spaces.

clean :: String -> String
clean = filter (`elem` alphabet ++ ['0'..'9']) . map toUpper

To create the checkerboard (without indices, since we need to the lookups both ways), we need to put the three extra spaces in the correct place and the numbers in the correct positions.

board :: String -> [Int] -> String
board key = spaces (replace =<< nub (clean key ++ alphabet))
    where spaces    = foldl (\a x -> take x a ++ "_" ++ drop x a)
          replace c = c : (maybe "" id . lookup c $ zip alphabet
                              (map show [1..9] ++ "0" : repeat ""))

As you can see below, encrypting and decrypting are really the same thing in this algorithm, only one adds and subtracts. So we factor out all of the work into one function. The reason for not making all the sub-functions into top-level functions is that it saves us from having to pass the five cipher parameters all over the place.

run :: (Int -> Int -> Int) -> String -> [Int] -> Int -> String -> String
run op text ss add key = f $ show =<<
    zipWith (\a b -> mod (op (read [a]) b) 10)
            (toIndex =<< clean text)
            (cycle . map digitToInt $ show add) where
    f []       = []
    f (a:xs)   = if elem (digitToInt a) ss
                 then fromIndex ([a], take 1 xs) ++ f (tail xs)
                 else fromIndex ("" , [a]      ) ++ f xs
    fromIndex  = maybe "" return . look id
    toIndex    = maybe "" (uncurry (++)) . look flip
    look dir k = lookup k . dir zip indices $ board key ss
    indices    = [(y, show x) | y <- "" : map show ss, x <- [0..9]]

With that out of the way, encrypting and decrypting is trivial:

encipher :: String -> Int -> Int -> Int -> Int -> String -> String
encipher xs s1 s2 s3 = run (+) xs [s1, s2, s3]

decipher :: String -> Int -> Int -> Int -> Int -> String -> String
decipher xs s1 s2 s3 = run (-) xs [s1, s2, s3]

Let’s see if our encryption works correctly:

main :: IO ()
main = do print $ go encipher "bonsai code"
          print $ go decipher "2B1ABA71OB1H2LBB"
       where go f text = f text 2 5 9 2641 "pablo picasso"

Yup. And at about a third of the Scheme solution size, I’d say that wraps things up nicely.

Programming Praxis – Affine-Shift Cipher

In today’s Programming Praxis we have to implement the Affine-Shift Cipher. Let’s get going, shall we?

A quick import:

import Data.Char

Since both encoding an decoding have roughly the same structure, we’re going to abstract that out into a function.

convert :: (Int -> Int) -> String -> String
convert f = map (chr . (\i -> f (i - 65) `mod` 26 + 65) . ord . toUpper)

For decoding, we need to calculate the modular inverse of a number.

inverse :: Int -> Int -> Int
inverse x n = f (mod x n) 1 where
    f 0 _ = error "Numbers not coprime"
    f 1 a = a
    f y a = let q = - div n y in f (n + q * y) (mod (q * a) n)

Encoding and decoding is then simply a case of calling the convert function with the correct argument.

encode :: Int -> Int -> String -> String
encode a b = convert (\i -> a*i + b)

decode :: Int -> Int -> String -> String
decode a b = convert (\i -> inverse a 26 * (i-b))

All that’s left to do is test if everything works correctly.

main :: IO ()
main = do print $ encode 5 8 "BONSAICODE" == "NAVUIWSAXC"
          print $ decode 5 8 "NAVUIWSAXC" == "BONSAICODE"

All clear.

Programming Praxis – Autokey

In today’s Programming Praxis we have another cipher algorithm. Let’s get started.

A quick import:

import Data.Char

First of all, we need a function to add and subtract characters.

combine :: (Int -> Int -> Int) -> Char -> Char -> Char
combine f a b = chr $ mod (f (ord a) (ord b) - 2 * 65) 26 + 65

Encrypting or decrypting is just a matter of using this combine function on all the letter pairs of the key and the message.

cipher :: (Int -> Int -> Int) -> String -> String -> String
cipher f key msg = zipWith (combine f) (clean msg) (clean key)
                   where clean = map toUpper . filter isLetter

When encrypting, we can simply append the message to the key.

encrypt :: String -> String -> String
encrypt key msg = cipher (+) (key ++ msg) msg

When decrypting, we instead need to append the unencrypted message, which we do not have yet. Fortunately, thanks to lazy evaluation we can simply recursively call the decrypt function. This means it will produce a stack overflow when fed an empty key, but since that would be useless anyway we don’t really care.

decrypt :: String -> String -> String
decrypt key msg = cipher (-) (key ++ decrypt key msg) msg

All that’s left is to test our functions:

main :: IO ()
main = do print $ encrypt "BONSAI" "Pablo Picasso"
          print $ decrypt "BONSAI" "QOODOXXCBDGD"

That seems to work just fine. Another one down.

Programming Praxis – Bifid Cipher

Today’s Programming Praxis problem is another cipher, specifically Bifid’s cipher. Let’s get started, shall we?

Some imports:

import Data.Char
import Data.List
import Data.List.HT hiding (unzip)
import Data.Map ((!), fromList)

There’s no J in the Bifid alphabet.

alphabet :: String
alphabet = delete 'J' ['A'..'Z']

Next we need some functions to get the index from a character and vice versa. The second line in fromIndex is only to get rid of a compiler warning; you can leave it out if you want to.

indices :: [(Int, Int)]
indices = zip (concatMap (replicate 5) [1..5]) (cycle [1..5])

toIndex :: Char -> (Int, Int)
toIndex c = fromList (zip alphabet indices) ! c

fromIndex :: [Int] -> Char
fromIndex [x, y] = fromList (zip indices alphabet) ! (x, y)
fromIndex _      = undefined

Next, we need a way to prepare the strings for the algorithm.

prepare :: String -> String
prepare = filter (`elem` alphabet) . replace "J" "I" . map toUpper

The basic structure of encode and decode is the same, only the way of getting the intermediate data in the right order differs.

encode :: String -> String
encode = map fromIndex . sliceVertical 2 . uncurry (++) .
         unzip . map toIndex . prepare

decode :: String -> String
decode xs = map fromIndex . sliceHorizontal (length xs) .
            concatMap ((\(x, y) -> [x, y]) . toIndex) $ prepare xs

And, as usual, some tests to see if everything’s working properly:

main :: IO ()
main = do print $ encode "BONSAICODE"
          print . decode $ encode "BONSAICODE"

Looks like it is. Another one down.

Programming Praxis – Ron’s Cipher #4

In today’s Programming Praxis problem, we have to implement the RC4 cipher, which is often used in protocols such as SSL and WEP. Let’s have a go, shall we?

First, some imports:

import Data.Bits
import Data.Char
import Data.IntMap ((!), fromList, insert, size, IntMap)

In this algorithm we’re going to have to swap two elements of a list twice, so let’s make a function for it. In order to speed this operation up, we’re going to use IntMaps instead of plain lists.

swap :: Int -> Int -> IntMap a -> IntMap a
swap i j a = insert j (a ! i) $ insert i (a ! j) a

The algorithm consists of two steps. The first step is to create a list of 256 integers based on the key.

rc4init :: IntMap Char -> IntMap Int
rc4init key = snd $ foldl (\(j, a) i ->
    let j' = mod (j + a ! i + ord (key ! mod i (size key))) 256
    in (j', swap i j' a)) (0, s) [0..255] where
    s = fromList $ zip [0..] [0..255]

In the second step, we create a stream of characters based on the result of step 1, which is xor’ed with the input string.

rc4 :: String -> String -> String
rc4 key = map chr . zipWith xor (stream key) . map ord where
    stream = s 0 0 . rc4init . fromList . zip [0..]
    s i' j' k' = k ! (mod (k ! i + k ! j) 256) : s i j k where
                 i = mod (i' + 1) 256
                 j = mod (j' + k' ! i) 256
                 k = swap i j k'

Let’s see if that works correctly:

main :: IO ()
main = do print $ rc4 "Kata" "Bonsai Code"
          print . rc4 "Kata" $ rc4 "Kata" "Bonsai Code"

Yup. 11 lines, not too shabby.

Programming Praxis – Blum Blum Shub

In today’s Programming Praxis problem we have to implement a stream cipher based on the Blum Blum Shub method. Let’s get started.

First our imports:

import Data.Bits
import Data.Char

This is our random number generator. I’m using the least significant 3 bits instead of just one because it scrambles the original message a bit more.

rng :: Int -> Int -> [Int]
rng m = map (.&. 7) . tail . iterate (\n -> mod (n ^ 2) m)

Encoding or decoding is a simple matter of xor’ing the message and the random number stream.

cipher :: Int -> Int -> Int -> String -> String
cipher s p q = map chr . zipWith xor (rng (p * q) s) . map ord

And that’s all there is to it. Let’s see if it works:

main :: IO ()
main = do print $ cipher 3 11 19 "Bonsai Code"
          print . cipher 3 11 19 $ cipher 3 11 19 "Bonsai Code"

Seems to work just fine. Not bad for just two lines of code.

Programming Praxis – The Daily Cryptogram

Today’s Programming Praxis problem is an interesting one: we have to write a program to solve monoalphebetic substitution ciphers.

The algorithm we’re going to use is by no means perfect, but for the example cryptogram, as well as a few other test cases, it generally gives a good enough approximation that only a little bit of human help is needed to get the full solution. It also has the benefit of being nice and short.

First, our imports:

import Data.Char
import Data.List
import qualified Data.Map as M
import GHC.Exts

We’re going to be using a dictionary-based approach. In order for that to work, we need a way to see if a given dictionary word can fit the pattern defined by the crypto word. We do this by looking at the first letter of the crypto and the dictionary word. If we already have a partial solution key, we check if the decoded letter is the same as that of the dictionary word. If we don’t, we add the relationship between the two letters to the solution key. Then we check the rest of the two words in the same way.

match :: M.Map Char String -> String -> String -> Bool
match _ []     []     = True
match k (c:cs) (p:ps) = M.findWithDefault [p] c k == [p] &&
                        match (M.insert c [p] k) cs ps
match _ _      _      = False

To apply the solution key to an encrypted string, we replace all the letters that exist in the key with their decoded equivalents, leaving the rest as is.

substitute :: M.Map Char String -> String -> String
substitute key = concatMap (\c -> M.findWithDefault [c] c key)

To get a series of potential keys, we look at every word of the encrypted text and see which dictionary words can still be substituted for them. If there are less than 100 options for a word, we generate all the keys that would result from those substitutions.

getKeys :: M.Map Char String -> [String] -> String -> [M.Map Char String]
getKeys k dict c = [M.fromList .
    unionBy (\(a,x) (b,y) -> a == b || x == y) (M.assocs k) .
    zip w $ map return p | w <- words c,
    let ps = filter (match k w) dict, length ps < 100, p <- ps]

We score keys by the amount of letters of they decrypt; the more, the better.

score :: M.Map Char String -> String -> Int
score k = negate . length . filter isLower . substitute k

We iterate this process a couple of times by feeding the resulting keys into a new iteration of the algorithm. In order to prevent combinatorial explosion, we only keep the 10 best keys of each generation.

findBestKeys :: Int -> [String] -> String -> [M.Map Char String]
findBestKeys n dict c = iterate (take 10 . sortWith (`score` c) .
    concatMap (\k -> getKeys k dict c)) [M.empty] !! n

‘Solving’ a crpytogram, i.e. showing the 10 best candidates and letting the user interpret them, means finding the best keys and showing the resulting substitutions. The first argument determines how many generations are performed, which determines the quality of the solution. For some cryptograms you may have to pay around with this a little. In my tests, something in the order of 3-7 usually works fairly well.

solve :: Int -> [String] -> String -> [String]
solve n dict c = map (`substitute` c) $ findBestKeys n dict $
                 filter (\x -> isAlpha x || isSpace x) c

Let’s see if our little algorithm works. For our dictionary we use english-words.10, a file that can be found in SCOWL, a Spell-Checker Oriented Word List (more info here). It is a list of common English words that offers a good balance between quality (it works better for my algorithm than the usr/dict/words file from Linux does) and speed (it’s just under 5000 words, which means that I get a solution in less than a second).

crypto = "P OYUUAOEXYW YM AEFGAD, FZGPEAG JAATUL, MYC ENA " ++
         "AGFOPEXYW PWG AWSYLVAWE YM ENA DPHHL ZCYICPVVAC"

main :: IO ()
main = do dict <- fmap lines $ readFile "english-words.10"
          mapM_ print $ solve 7 dict crypto

The resulting decrypted text is “a collection of etudew, updated JeeTls, for the education and enSosment of the waHHs programmer”, which looks strikingly similar to the old motto of Programming Praxis – “a collection of etudes, updated weekly, for the education and enjoyment of the savvy programmer”. As you can see, there are a few errors and it doesn’t get everything, but that is because these words are not in the dictionary file I used. Still, for an 18-line algorithm I’d say it works well enough. A trigram- or genetic algorithm-based solution might work better, but we’ll see that when the official solution is released.

Programming Praxis – The Playfair Cipher

Today’s Programming Praxis problem is about the Playfair Cipher, a way of encrypting messages that was used in the first and second World Wars. Our target is 44 lines, so let’s get cracking.

We’re going to need a bunch of imports on this one:

import Data.Char
import Data.List
import Data.List.HT
import Data.List.Split
import qualified Data.Map as M

And for convenience, we make a type definition for Keys.

type Key = M.Map (Int, Int) Char

In order for the algorithm to work, we’re going to have to filter all the input so that all we get is capital letters without a J.

process :: String -> String
process = replace "J" "I" . map toUpper . filter isLetter

Instead of working with a block, we turn the key into a map of of x-y coordinates to letters. This makes the rest of the algorithm simpler.

key :: String -> Key
key = M.fromList . concat .
      zipWith (\y -> zipWith (\x c -> ((x, y), c)) [0..]) [0..] .
      chunk 5 . (`union` delete 'J' ['A'..'Z']) . nub . process

bigram encodes or decodes two letters at a time according to the three given rules.

bigram :: Key -> Int -> Char -> Char -> String
bigram k dir c1 c2
    | y1 == y2  = get (x1 + dir, y1) : [get (x2 + dir, y2)]
    | x1 == x2  = get (x1, y1 + dir) : [get (x2, y2 + dir)]
    | otherwise = get (x2, y1)       : [get (x1, y2)]
    where (x1, y1) = head . M.keys $ M.filter (== c1) k
          (x2, y2) = head . M.keys $ M.filter (== c2) k
          get (x,y) = k M.! (mod x 5, mod y 5)

Encoding consists of inserting Xs in the correct places and then encoding all the bigrams.

encode' :: Key -> String -> String
encode' _ []       = []
encode' k [x]      = encode' k (x : "X")
encode' k (x:y:xs) | x == y    = encode' k [x] ++ encode' k (y:xs)
                   | otherwise = bigram k 1 x y ++ encode' k xs

Decoding is simpler, since there are no special cases there.

decode' :: Key -> String -> String
decode' k = concatMap (\[x,y] -> bigram k (-1) x y) . chunk 2

And finally, two convenience functions so we can work with strings directly.

encode :: String -> String -> String
encode k = encode' (key k) . process

decode :: String -> String -> String
decode k = decode' (key k) . process

All that remains is to test if everything works correctly:

main :: IO ()
main = do print $ encode "PLAYFAIR" "PROGRAMMING PRAXIS"
          print $ decode "PLAYFAIR" "LIVOBLKZEDOELIYWCN"

And we’re done. Interestingly, if you try to decode the 1943 message, you’ll notice two errors in the result: it says Blackess instead of Blackett and coce instead of cove. I wonder if the errors were made by the original sender or by the first person to type it on a computer.

Anyway, the solution is 24 lines, just over half the size of the Scheme version. That will do nicely.