Archive for June, 2011

Programming Praxis – Thank God It’s Friday!

June 24, 2011

In today’s Programming Praxis exercise, our goal is to implement three functions related to dates: two ways to calculate the day of the week for a given date and one to calculate the ‘doomsday’ of a given year. Let’s get started, shall we?

To make the results a bit easier to work with we make a data type with the days of the week.

data Weekday = Sun | Mon | Tue | Wed | Thu | Fri | Sat deriving (Enum, Eq, Show)

The algorithms are just a bit a math.

gauss :: Int -> Int -> Int -> Weekday
gauss y m d = toEnum $ mod (d + floor (2.6 * fromIntegral
  (mod (m - 2) 12) - 0.2) + y' + div y' 4 + div c 4 - 2*c) 7 where
    (c,y') = divMod (if m < 3 then y - 1 else y) 100

sakamoto :: Int -> Int -> Int -> Weekday
sakamoto y m d = toEnum $ mod (y + div y 4 - div y 100 +
    div y 400 + [0,3,2,5,0,3,5,1,4,6,2,4] !! (m - 1) + d) 7

conway :: Int -> Weekday
conway y = toEnum $ mod (q + r + div r 4 + 5*(c+1) + div c 4 + 4) 7
    where (c, (q,r)) = (div y 100, divMod (mod y 100) 12)

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ gauss 2011 6 24 == Fri
          print $ sakamoto 2011 6 24 == Fri
          print $ conway 2011 == Mon
Advertisements

Programming Praxis – Big Numbers: Input And Output

June 14, 2011

In today’s Programming Praxis exercise, our task is to write functions to convert Big Numbers to and from strings. Let’s get started, shall we?

To convert from a string, we simply convert each digit to the correct value, multiplying them by the base as we go along.

readBase :: (Num a, Enum a) => a -> String -> a
readBase b ('-':xs) = - readBase b xs
readBase b xs       = foldl (\a x -> b * a + val x) 0 xs where
    val d = maybe (error "unrecognized digit") id . lookup d $ zip
            (['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']) [0..]

To convert to a string, we divide by the base until we reach zero. The remainders form the digits of the output.

showBase :: Integral a => a -> a -> String
showBase b n = if n < 0 then '-' : showBase b (abs n) else
               map (digit . snd) $ m : reverse ms  where
    ((_:ms), (m:_)) = span ((> 0) . fst) $ iterate (flip divMod b . fst) (n, 0)
    digit d = maybe undefined id . lookup d . zip [0..] $
              ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']

While we’re at it let’s also make BigNum an instance of Read and Show, the typeclasses that normally handle conversion to and from strings.

instance Read BigNum where
    readsPrec _ = return . first (readBase 10) . split where
        split ('-':xs) = first ('-':) $ split xs
        split xs       = span (`elem` ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']) xs

instance Show BigNum where
    show = showBase 10

Some tests to see if everything is working properly:

main :: IO ()
main = do print $ readBase 10 "1234"   == ( 1234 :: BigNum)
          print $ readBase 10 "-1234"  == (-1234 :: BigNum)
          print $ readBase  2 "101010" == (   42 :: BigNum)
          print $ read "-1234"         == (-1234 :: BigNum)
          print $ showBase 10 ( 1234 :: BigNum) ==   "1234"
          print $ showBase 10 (-1234 :: BigNum) ==  "-1234"
          print $ showBase  2 (   42 :: BigNum) == "101010"
          print $ show        (-1234 :: BigNum) ==  "-1234"

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 – Big Numbers: Division

June 7, 2011

In today’s Programming Praxis exercise, our goal is to add division to our Big Number library. Let’s get started, shall we?

Because I found two bugs in the existing code and to avoid spreading the code around too much, this week I’ll post the full code for the module again.

I’ve added some imports:

import Control.Arrow
import Data.List
import Data.Ratio
import Test.QuickCheck

The data type, base and Ord instance are unchanged.

data BigNum = B Int [Int] deriving (Eq, Show)

base :: Integer
base = 1000

instance Ord BigNum where
    compare (B l1 ds1) (B l2 ds2) = case compare l1 l2 of
        EQ -> maybe EQ id . find (/= EQ) . reverse $ zipWith compare ds1 ds2
        c  -> c

While testing division I discovered that the result of a subtraction operation wasn’t trimmed of leading zeroes. The new definition for + solves this.

instance Num BigNum where
    a@(B l1 ds1) + b@(B l2 ds2) = B (length t * signum l) (reverse t) where
        B l _ = if abs b > abs a then b else a
        (_,t) = span (== 0) . reverse . f 0 $ (if abs b > abs a then flip else id)
             (prep $ if signum l1 == -signum l2 then (-) else (+)) ds1 ds2
        prep op (x:xs) (y:ys) = op (toInteger x) (toInteger y) : prep op xs ys
        prep _  xs     ys     = map toInteger $ xs ++ ys
        f r (x:xs) = let (d,m) = divMod (r + x) base in fromIntegral m : f d xs
        f r []     = if r == 0 then [] else [fromIntegral r]
    (B l1 ds1) * (B l2 ds2) = B (signum l1 * signum l2 * sl) sds where
        B sl sds = sum $ mult ds1 ds2
        mult (x:xs) (y:ys) = fromIntegral (toInteger x * toInteger y) :
                             map shift (mult xs (y:ys)) ++
                             map shift (mult [x] ys)
        mult _     _  = []
        shift (B l ds) = B (l + 1) (0 : ds)
    negate (B l ds) = B (-l) ds
    abs (B l ds)    = B (abs l) ds
    signum (B l _)  = fromIntegral $ signum l
    fromInteger n | n < 0     = negate $ fromInteger (-n)
                  | otherwise = B (length ds) (map fromIntegral ds)
                  where ds = tail $ f (n,0)
                        f (0,m) = [m]
                        f (d,m) = m : f (divMod d base)

These two instances aren’t strictly necessary, but making a data type an instance of Integral requires it instances Enum and Real as well. The definitions are trivial enough, so I added them.

instance Enum BigNum where
    fromEnum = fromIntegral . toInteger
    toEnum   = fromInteger . fromIntegral

instance Real BigNum where
    toRational = (% 1) . toInteger

The second bug I found was that converting a Big Number to an Integer didn’t keep the sign of the number. This is now fixed. Also, since we’re now instancing Integral I could give it the proper name.

instance Integral BigNum where
    toInteger (B l ds) = foldr (\x a -> fromIntegral (signum l * x) + base * a) 0 ds

For the actual division, I developed my own algorithm since I couldn’t find a good explanation of Knuth’s algorithm. It fairly simple, though probably a bit less efficient than Knuth’s version. Determine how often the denominator can go in the numerator based on the first digit group of the denominator (d1) and the first digit group of the numerator (n1). If n1 is less than d1, the second digit group of the numerator (n2) is used instead, and a value equal to how often d1 goes into the base is added. The resulting value is multiplied by the denominator, subtracted from the numerator and the algorithm is called recursively. Thanks to the Integral typeclass we get the other functions (div, mod, etc.) for free.

    quotRem n@(B l1 ds1) d@(B l2 ds2)
        | d == 0         = error "Division by zero"
        | n < 0 || d < 0 = let (q',r') = quotRem (abs n) (abs d)
                           in (signum n * signum d * q', signum n * r')
        | n < d          = (0, n)
        | otherwise      = first (+ q) $ quotRem (n - d*q) d where
        (n1,n2,d1) = (last ds1, last $ tail ds1, last ds2)
        q = if n1 < d1 then shift (l1 - l2 - 1) $ div n2 d1 +
                            fromIntegral (div base (fromIntegral d1))
                       else shift (l1 - l2) $ div n1 d1
        shift s i = B (s + 1) $ (replicate s 0) ++ [i]

Since there are plenty of possible corner cases I automated the testing using QuickCheck to make sure there is no difference between Integer and BigNum division.

divTest :: Integer -> Integer -> Property
divTest a b = b /= 0 ==> quotRem a b == (toInteger q, toInteger r)
    where (q, r) = quotRem (fromInteger a :: BigNum) (fromInteger b)

main :: IO ()
main = do print $ div 12345678 (3456 :: BigNum) == 3572
          print $ mod 12345678 (3456 :: BigNum) == 846
          quickCheck divTest

Programming Praxis – Mersenne Primes

June 3, 2011

In today’s Programming Praxis exercise, our goal is to calculate the Mersenne prime exponents up to 256. Let’s get started, shall we?

A quick import:

import Data.Numbers.Primes

The Mersenne primes can be determine with a simple list comprehension. Although the Lucas-Lehmer test officially doesn’t work for M2, in practice it works just fine so there is no need to make it a special case.

mersennes :: [Int]
mersennes = [p | p <- primes,
    iterate (\n -> mod (n^2 - 2) (2^p - 1)) 4 !! p-2 == 0]

A test shows that the algorithm is working correctly. Piece of cake.

main :: IO ()
main = print $ takeWhile (<= 256) mersennes
               == [2,3,5,7,13,17,19,31,61,89,107,127]