Posts Tagged ‘playfair’

Programming Praxis – Steganography

June 10, 2011

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 – The Playfair Cipher

July 3, 2009

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.