Programming Praxis – Run Length Encoding

In today’s Programming Praxis exercise we have to implement a run length encoding algorithm. The provided Scheme solution weighs in at 27 lines. Let’s see if we can do any better in Haskell.

First, two imports.

import Data.List
import Data.List.Split

Compressing is easy: use group and chunk to separate the string into runs of the appropriate length and then apply tilde encoding as necessary.

compress :: String -> String
compress s = f =<< chunk 26 =<< group s where
    f xs = if length xs < 4 && take 1 xs /= "~" then xs
           else '~' : toEnum (length xs + 64) : take 1 xs

Expanding is easier still and can be done entirely through pattern matching.

expand :: String -> String
expand []           = []
expand ('~':r:c:xs) = replicate (fromEnum r - 64) c ++ expand xs
expand (c:xs)       = c : expand xs

And of course we have to test if everything works correctly.

main :: IO ()
main = do print $ compress org == rle
          print $ expand rle == org
          where org = "ABBB~CDDDDDEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE"
                rle = "ABBB~A~C~ED~ZE~DE"

Everything seems to be working and at 6 lines that’s 4,5 times shorter than the Scheme solution. Not bad.

Programming Praxis – Soundex

In today’s Programming Praxis exercise we have to implement the soundex algorithm for encoding people’s last names. Let’s get started, shall we?

Some imports:

import Data.Char
import Data.List

The algorithm itself is not all that complicated. My only mistake was that I failed to account for names where the second letter was equal to the first, such as Lloyd, since initially I only grouped after removing the first letter.

soundex :: String -> String
soundex = f . map head . group . map toUpper where
    f []     = []
    f (x:xs) = x : take 3 [toNum c | c <- xs ++ repeat '0',
                                     notElem c "AEHIOUWY"]
    toNum c = maybe '0' snd . find (elem c . fst) $
              zip (words "BFPV CGJKQSXZ DT L MN R") ['1'..]

A test to see if everything is working correctly:

main :: IO ()
main = do test ["Euler",  "Gauss", "Hilbert",
                "Knuth",  "Lloyd", "Lukasiewicz"]
          test ["Ellery", "Ghosh", "Heilbronn",
                "Kant",   "Ladd",  "Lissajous"]
          where test xs = print $ map soundex xs == result
                result = ["E460", "G200", "H416",
                          "K530", "L300", "L222"]

Yup, and at only about a third the size of the Scheme solution I’d say that’s not bad.

Programming Praxis – Numerical Integration

In today’s Programming Praxis exercise we have to do some numerical integration. Let’s get started.

Since the first three algorithms all work roughly the same, and as a programmer I hate repeating myself, we’re going to make a generic integration function to abstract out the common stuff.

int combine f a b n = sum $ map g [0..n - 1] where
    w    = (b - a) / n
    lo i = a + w * i
    g i  = w * combine (f $ lo i) (f $ lo i + w/2) (f $ lo i + w)

Now we can just define the three simple integration methods in terms of what we want to do with the low, mid and high points.

intRect = int (\_ m _ -> m)

intTrap = int (\l _ h -> (l + h) / 2)

intSimp = int (\l m h -> (l + 4 * m + h) / 6)

The intAdapt function is pretty much the same as the Scheme version.

intAdapt m f a b epsilon = if abs (g10 - g5) < e then g10 else
    intAdapt m f a mid (Just e) + intAdapt m f mid b (Just e)
    where g5  = m f a b 5
          g10 = m f a b 10
          mid = (a + b) / 2
          e   = maybe 1e-7 id epsilon

Using adaptive integration for prime counting:

approxPi n = round $ intAdapt intSimp (recip . log) 2 n Nothing

And finally a test to show that everything’s working properly.

main = do print $ intRect cube 0 1 10000
          print $ intTrap cube 0 1 10000
          print $ intSimp cube 0 1 10000
          print $ approxPi 1e21
       where cube x = x * x * x

Programming Praxis – Proving Primality

In today’s Programming Praxis exercise we have to implement an algorithm to prove the primality of a number. Let’s get started, shall we?

Some imports:

import Data.Bits
import Data.List

the tdFactors and expm functions have both been featured in previous exercises.

tdFactors :: Integer -> [Integer]
tdFactors n = f n [2..floor . sqrt $ fromIntegral n] where
    f _ []     = []
    f r (x:xs) | mod r x == 0 = x : f (div r x) (x:xs)
               | otherwise    = f r xs

expm :: Integer -> Integer -> Integer -> Integer
expm b e m = foldl' (\r (b', _) -> mod (r * b') m) 1 .
             filter (flip testBit 0 . snd) .
             zip (iterate (flip mod m . (^ 2)) b) .
             takeWhile (> 0) $ iterate (`shiftR` 1) e

Unfortunately, these math-heavy problems typically resist shortening, so this is pretty similar to the Scheme solution.

isPrime :: Integer -> Bool
isPrime n = f 2 $ tdFactors (n - 1) where
    f _ []     = False
    f b (q:qs) | expm b (n - 1)         n /= 1 = f (b + 1) (q:qs)
               | expm b (n - 1 `div` q) n /= 1 = True
               | otherwise                     = f b qs

All that’s left is a quick test:

main :: IO ()
main = print . isPrime $ 2^89 - 1