Archive for June, 2009

Programming Praxis – Steve Yegge’s Phone-Screen Coding Exercises

June 30, 2009

Today’s Programming Praxis problem is an easy one. In 2005, Steve Yegge posted an article about interviewing programmers that listed 7 simple programming exercises for phone screening. These assignments are a perfect example of ‘Bonsai code’, since they require so little code. The scheme solution clocks in at 22 lines, or just over 3 lines per function on average. Let’s see how Haskell does.

Our imports (the latter one is only to ensure type safety in exercise 7):

import Text.Printf
import Data.Word

1. Write a function to reverse a string

Normally you would just use the reverse function from the Prelude (like the Scheme solution does), but I consider that cheating, since the assignment says to write our own. Fortunately, the full solution is not much longer:

reverse' :: String -> String
reverse' = foldl (flip (:)) []

2. Write a function to compute the Nth fibonacci number

The function to produce an infinite list of Fibonacci numbers is a well-known example of Haskell’s brevity. All we need to fulfill the assignment is to get the correct one:

fib :: (Num a) => Int -> a
fib n = fibs !! n where fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

3. Print out the grade-school multiplication table up to 12 x 12

The only non-one-liner of the bunch, but still very trivial.

timesTable :: IO ()
timesTable = mapM_ putStrLn [concat
    [printf "%4d" (a * b) | a <- [1..12]] | b <- [1..12 :: Int]]

4. Write a function that sums up integers from a text file, one per line.

Aside from the map read bit it’s almost plain English.

sumFile :: FilePath -> IO ()
sumFile path = print . sum . map read . lines =<< readFile path

5. Write a function to print the odd numbers from 1 to 99.

And another one that almost anyone should be able to understand.

printOdds :: IO ()
printOdds = print $ filter odd [1..99]

6. Find the largest int value in an int array.

As with the reverse assignment, we would normally just use the built-in maximum function here. But since that’s cheating, we use another simple fold:

largest :: [Int] -> Int
largest = foldl max minBound

7. Format an RGB value (three 1-byte numbers) as a 6-digit hexadecimal string.

Printf to the resque. As mentioned in the imports, we could just use Ints and get rid of one of our imports, but this way we guarantee that only 1-byte numbers can be passed in.

toHex :: Word8 -> Word8 -> Word8 -> String
toHex = printf "%02x%02x%02x"

And that brings us to 10 lines of code in total, which is less than half the Scheme solution size. I just love one-liners 🙂

Programming Praxis – Treaps

June 26, 2009

Today’s Programming Praxis problem is about Treaps – binary trees that are more or less balanced thanks to random numbers. The provided solution is 58 lines, so we have quite a bit of work to do. Let’s get started.

First our imports:

import Control.Monad
import Data.Char
import qualified Data.List.Key as K
import System.Random

As mentioned in the intro, the data structure is, for all intents and purposes, a binary tree.

data Treap k a = Nil | Node Int k a (Treap k a) (Treap k a)

Nil nodes have a priority of -1.

priority :: Treap k a -> Int
priority Nil = -1
priority (Node p _ _ _ _) = p

Rotating left and right requires some node reshuffling:

rotLeft :: Treap k a -> Treap k a
rotLeft (Node p k a l (Node rp rk ra rl rr)) =
    Node rp rk ra (Node p k a l rl) rr
rotLeft t = t

rotRight :: Treap k a -> Treap k a
rotRight (Node p k a (Node lp lk la ll lr) r) =
    Node lp lk la ll (Node p k a lr r)
rotRight t = t

This function automatically applies the correct rotations:

rot :: Treap k a -> Treap k a
rot Nil = Nil
rot t@(Node p _ _ l r) | p < priority l = rotRight t
                       | p < priority r = rotLeft t
                       | otherwise      = t

Lookup works the same as in any binary tree.

find :: Ord k => k -> Treap k a -> Maybe a
find _  Nil = Nothing
find k' (Node _ k a l r) | k' < k    = find k' l
                         | k' > k    = find k' r
                         | otherwise = Just a

And updating is also not that different. The only annoyance is that we have to do it in the IO monad, since we need random numbers.

update :: Ord k => (a -> a -> a) -> k -> a -> Treap k a -> IO (Treap k a)
update _ k' a' Nil = fmap (\r -> Node r k' a' Nil Nil) $
                     randomRIO (0, maxBound)
update f k' a' (Node p k a l r)
    | k' < k    = fmap (\n -> rot $ Node p k a n r) (update f k' a' l)
    | k' > k    = fmap (rot . Node p k a l) (update f k' a' r)
    | otherwise = return $ Node p k' (f a' a) l r

Inserting is just a special case of updating:

insert :: Ord k => k -> a -> Treap k a -> IO (Treap k a)
insert = update const

For deleting, we need a way the combine the two remaining subtrees. This requires some rotation.

deroot :: Treap k a -> Treap k a
deroot Nil = Nil
deroot t@(Node _ _ _ l r)
    | priority l < priority r = d deroot id $ rotLeft t
    | otherwise               = d id deroot $ rotRight t
    where d fl fr = (\(Node p k a l' r') -> Node p k a (fl l') (fr r'))

That makes deleting a simple matter of applying deroot at the correct location.

delete :: Ord k => k -> Treap k a -> Treap k a
delete _ Nil = Nil
delete k' t@(Node p k a l r)
    | k' < k    = Node p k a (delete k' l) r
    | k' > k    = Node p k a l (delete k' r)
    | otherwise = deroot t

Converting a treap to a list is just simple recursion.

toList :: Treap k a -> [(k, a)]
toList Nil = []
toList (Node _ k a l r) = toList l ++ [(k, a)] ++ toList r

And there we go. Now to test it on the word frequency problem:

main :: IO ()
main = mapM_ print =<< wordFreqs 25 =<< readFile "bible.txt"

wordFreqs :: Int -> String -> IO [(String, Int)]
wordFreqs n = fmap (take n . reverse . K.sort snd . toList) .
              foldM (\a w -> update (+) w 1 a) Nil .
              map (filter isAlpha) . words

Works as expected. At 40 lines it’s about a 30% reduction compared to the scheme code. Not bad.

Programming Praxis – The Mod Out System

June 23, 2009

Today’s Programming Praxis problem is an easy one: all we have to do is convert a string that contains numbers and number ranges to a full list of numbers. The original PL/SQL solution is 49 lines, and the scheme solution has 9. Let’s see if we can bring that down further still.

Our import:

import Data.List.Split

What we have to do is pretty simple: first we split the string on the commas. The resulting chunks are split on the dash. The resulting numbers are converted to Ints. Since we need two numbers to define a range, we cycle these numbers, and take the range between the first two numbers.

modOut :: String -> [Int]
modOut = concatMap ((\(a:b:_) -> [a..b]) .
    cycle . map read . sepBy "-") . sepBy ","

A quick test reveals that everything’s working correctly:

main :: IO ()
main = print $ modOut "1-6,9,13-19"

And so we’ve reduced the solution size by another factor of three. That will do nicely.

Who Owns The Zebra Reloaded

June 22, 2009

For the Who Owns the Zebra problem I initially tried a solution based on a list comprehension. I was, however, unable to get it to work in any reasonable time. Today Rofl_Waffler posted a solution on reddit that showed me why: I put all the conditions at the end, which meant that all possible solutions had to be generated. By interleaving the options and the conditions, Haskell does do the smart filtering you would expect. Although it does require careful ordering of the code, the resulting solution is a lot shorter. Rofl_Waffler’s solution uses a do statement with guards, but I figured I could make it even better using a list comprehension and some other minor adjustments.

Our import:

import Data.List

In this approach all permutations of the five properties are generated. To figure out the position of a specific option we use the following function:

indexOf :: (Eq a) => [a] -> a -> Int
indexOf xs x = head $ elemIndices x xs

We also need to be able to tell if an option is next to or to the right of another option:

nextTo :: Int -> Int -> Bool
nextTo a b = abs (a - b) == 1

rightOf :: Int -> Int -> Bool
rightOf a b = a == b + 1

A small convenience function to generate the different permutations:

options :: String -> [[String]]
options = permutations . words

And the solution to the problem itself.

solution :: [[String]]
solution = head [transpose [cs, os, ds, ss, ps] |
    cs <- options "red green ivory yellow blue",
    let color = indexOf cs,
    color "green" `rightOf` color "ivory",
    os <- options "english spaniard ukranian norwegian japanese",
    let owner = indexOf os,
    owner "norwegian" == 0,
    owner "english" == color "red",
    owner "norwegian" `nextTo` color "blue",
    ds <- options "coffee tea milk juice water",
    let drinks = indexOf ds,
    drinks "milk" == 2,
    drinks "coffee" == color "green",
    owner "ukranian" == drinks "tea",
    ss <- options "old_gold kools chesterfields parliaments lucky_strike",
    let smokes = indexOf ss,
    smokes "kools" == color "yellow",
    smokes "lucky_strike" == drinks "juice",
    owner "japanese" == smokes "parliaments",
    ps <- options "dog snails fox horse zebra",
    let pet = indexOf ps,
    owner "spaniard" == pet "dog",
    smokes "old_gold" == pet "snails",
    smokes "chesterfields" `nextTo` pet "fox",
    smokes "kools" `nextTo` pet "horse"]

A quick test shows that we still get the correct answer.

main :: IO ()
main = mapM_ print solution

Now we only need 30 lines, which is a reduction of just under 50%. The lesson here: put conditions in list comprehensions as close to the generators as possible.

Programming Praxis – Monte Carlo factorization

June 19, 2009

In today’s Programming Praxis problem we have to implement John Pollard’s factorization algorithm. Our target is 16 lines (I’m not counting the code for the primality test, since we did that already).

First, we’re going to need to reuse the code from the Miller-Rabin primality test exercise, since we need to determine whether or not the number is prime:

import Control.Arrow
import Data.Bits
import Data.List
import System.Random

isPrime :: Integer -> StdGen -> Bool
isPrime n g =
    let (s, d) = (length *** head) . span even $ iterate (`div` 2) (n-1)
        xs = map (expm n d) . take 50 $ randomRs (2, n - 2) g
    in all (\x -> elem x [1, n - 1] ||
                  any (== n-1) (take s $ iterate (expm n 2) x)) xs

expm :: Integer -> Integer -> Integer -> Integer
expm m e b = 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

There’s not much more to the factor function than simply writing down the algorithm. It’s just math with Haskell syntax, really. The only thing you have to take care of is not to calculate gcd (x-y) n when x and y are still 2, since that will give you an incorrect result.

factor :: Integer -> Integer -> Integer
factor c n = factor' 2 2 1 where
    f x = mod (x * x + c) n
    factor' x y 1 = factor' x' y' (gcd (x' - y') n) where
                        (x', y') = (f x, f $ f y)
    factor' _ _ d = if d == n then factor (c + 1) n else d

And factors does little more than recursively calling factor, while filtering out factors of two and making sure not to call factor on a prime (since the algorithm is not designed for that).

factors :: Integer -> StdGen -> [Integer]
factors n g = sort $ fs n where
    fs x | even x      = 2 : fs (div x 2)
         | isPrime x g = [x]
         | otherwise   = f : fs (div x f) where f = factor 1 x

And to test:

main :: IO ()
main = print . factors (2^98 - 1) =<< getStdGen

The end result is 9 lines of code, which was to be expected, given that it’s just a question of writing math in your language’s syntax.

Programming Praxis – Who Owns The Zebra?

June 16, 2009

In Today’s Programming Praxis problem we have to solve a logic puzzle. The provided solution uses a 182-line logic programming library and then takes 36 lines to solve the problem. I didn’t feel like porting 182 lines from Scheme to Haskell, so I rolled my own solution.  It’s going to be a slightly longer one than usual though, so let’s dive right in.

Our imports:

import Data.List
import qualified Data.Map as M

We’re going to handle the constraints by applying them to a two-dimensional grid. One axis holds the position of the house (first, second, etc.) and the other the various properties (nationality, color, etc.). Each cell holds the remaining options for that combination of house and property. By applying constraints we’re going to remove options until each cell has only one option left. It’s a bit like sudoku puzzles if you think about it.

type Grid = M.Map String (M.Map Int [String])

In the problem we have four types of constraints, which we encode in an ADT:

data Constraint = Link (String, String) (String, String)
                | PosLink (String, String) Int
                | NextTo (String, String) (String, String)
                | RightOf (String, String) (String, String)
                deriving Eq

A convenience type to keep the type signatures a bit easier to read:

type Solver = ([Constraint], Grid)

Adding a constraint to a solver is trivial:

addConstraint :: Constraint -> Solver -> Solver
addConstraint c (cs, g) = (c : cs, g)

This function abstracts out some common logic. It removes options from the grid if the conditions to do so have been met.

removeIf :: (String, String) -> (String, String) ->
    [String -> String -> Int -> Grid -> Bool] -> Grid -> Grid
removeIf (f1, v1) (f2, v2) cs g = M.adjust (M.mapWithKey (\k ->
    if and [c f1 v1 k g | c <- cs] then delete v2 else id)) f2 g

Like removeIf, notAt abstract out some common code. It checks if a given value is still an option for the given property in another house.

notAt :: (Int -> Int) -> String -> String -> Int -> Grid -> Bool
notAt f f1 v1 i g = M.notMember (f i) (g M.! f1) ||
                    notElem v1 (g M.! f1 M.! (f i))

With that out of the way, the function to apply a constraint looks like this. Since most constraints work in two directions, we have to apply them in both directions.

runConstraint :: Constraint -> Grid -> Grid
runConstraint (Link a b) = removeIf a b conds . removeIf b a conds
    where conds = [(\f1 v1 k -> notElem v1 . (M.! k) . (M.! f1))]
runConstraint (PosLink (f1,v1) i) =
    M.adjust (M.update (const $ Just [v1]) i) f1
runConstraint (NextTo a b)  = removeIf a b [notAt pred, notAt succ]
runConstraint (RightOf a b) = removeIf a b [notAt pred] .
                              removeIf b a [notAt succ]

adjustOthers applies a function to all elements of a map except the given one, which we need for the next function.

adjustOthers :: Eq k => (v -> v) -> k -> M.Map k v -> M.Map k v
adjustOthers f k = M.mapWithKey (\k' v -> if k' == k then v else f v)

If a house has only one option left for a property than we can remove that option from all the other houses. Similarly, if a house is the only one that still has a certain option, we can remove the other options for that property.

simplify :: Grid -> Grid
simplify g = foldr ($) (M.mapWithKey (\_ v ->
    M.mapWithKey (\i x -> let d = x \\ concat (M.elems $ M.delete i v)
                          in if length d == 1 then d else x) v) g)
    [ M.adjust (adjustOthers (\\ take 1 x) i) f
    | (f, v) <- M.assocs g, (i, x) <- M.assocs v, length x == 1]

run simply runs all the constraints once.

run :: Solver -> Solver
run (cs, g) = (cs, simplify $ foldr runConstraint g cs)

Once all the constraints have been run, we might have fewer options available than we did at the beginning, which might open up new possibilities for more removal. apply keeps applying all the constraints until no further progress is made.

apply :: Solver -> Solver
apply = head . head . dropWhile (null . tail) . group . iterate run

If we had enough constraints to solve the problem with just constraint propagation we could stop here. Unfortunately, this doesn’t work on the problem we have to solve.  While it significantly reduces the available options, it can’t give a complete solution. So we’re going to have to do what any self-respecting logician would do in such a scenario: guess. If a property still has multiple options we choose one of them and see if we can solve it then. If not, we try the next option, or we do the same thing for the next property if none of the guesses helps solve the problem.

If any property still has more than one option the problem is not solved.

solved :: M.Map k (M.Map k' [v]) -> Bool
solved g = and [False | (_, v)  <- M.assocs g,
                        (_, xs) <- M.assocs v, length xs /= 1]

solve takes care of the guesswork, and also reformats the output to be more readable.

solve :: Solver -> [String]
solve s = map (unwords . map head) . transpose . map (M.elems) .
          M.elems $ head [ r | let (cs, g) = apply s,
          (f, v) <- M.assocs $ g, (i, xs) <- M.assocs v, x <- xs,
          let (_, r) = apply (cs, M.adjust (M.adjust (const [x]) i) f g),
          solved r ]

And there we have our constraint solver. Now for the problem. First we create the grid with all the options:

grid :: Grid
grid = M.fromList . zip (words "owner brand drink pet color") $
    map (M.fromList . zip [1..] . replicate 5)
    [words "Englishman Ukranian Norwegian Japanese Spaniard",
     words "Old_Gold Kools Chesterfields Lucky_Strike Parliaments",
     words "Coffee Tea Milk Orange_Juice Water",
     words "Dog Snails Horse Fox Zebra",
     words "Red Green Ivory Yellow Blue"]

Next we add all our constraints.

problem :: Solver
problem = foldr addConstraint ([], grid)
    [Link    ("owner", "Englishman")    ("color", "Red"),
     Link    ("owner", "Spaniard")      ("pet",   "Dog"),
     Link    ("drink", "Coffee")        ("color", "Green"),
     Link    ("owner", "Ukranian")      ("drink", "Tea"),
     RightOf ("color", "Ivory")         ("color", "Green"),
     Link    ("brand", "Old_Gold")      ("pet",   "Snails"),
     Link    ("brand", "Kools")         ("color", "Yellow"),
     PosLink ("drink", "Milk")          3,
     PosLink ("owner", "Norwegian")     1,
     NextTo  ("brand", "Chesterfields") ("pet",   "Fox"),
     NextTo  ("brand", "Kools")         ("pet",   "Horse"),
     Link    ("brand", "Lucky_Strike")  ("drink", "Orange_Juice"),
     Link    ("owner", "Japanese")      ("brand", "Parliaments"),
     NextTo  ("owner", "Norwegian")     ("color", "Blue")]

And finally we print the solution.

main :: IO ()
main = mapM_ putStrLn $ solve problem

That brings the total to 36 lines for the solver and 23 for the problem, and it runs in about 60 ms. I’d say that will do nicely.

Programming Praxis – Feynman’s Puzzle

June 12, 2009

Today’s Programming Praxis problem is about a long division puzzle by Richard Feynman. The provided solution is 14 lines of code. Since both his and my solution are little more than a simple list comprehension, there is not going to be much room for improvement, but let’s see what we can do.

We need a way to refer to specific digits of numbers. The provided solution does so by converting the number to a list of digits. This function just returns the nth digit of a number, starting with the least significant one. For instance, digit 1 1234 equals 4.

digit :: Int -> Int -> Int
nth `digit` n = n `mod` 10 ^ nth `div` 10 ^ (nth - 1)

As mentioned, this problem is most naturally solved with a list comprehension, so that is what we will use as well. The actual conditions are of course nearly identical to the scheme version, with the exception that the condition that a * n1 has four digits is unnecessary, and therefore removed in this version.

feinman :: [(Int, Int)]
feinman = [ (n1, n2)
          | b <- [1..9], a <- [0..9], c <- [0..9],
            d <- [1..9], e <- [0..9], f <- [0..9],
            a /= b, a /= c, a /= d, a /= e, a /= f, e < d,
            let n1 = 100 * b + 10 * a + c,
            let n2 = 1000 * d + 100 * e + 10 * a + f,
            n1 * n2 > 999999, n1 * n2 < 10000000,
            digit 3 (n1 * n2) == a,
            digit 1 (d * n1) == a, digit 2 (d * n1) == a,
            digit 1 (e * n1) == a, digit 3 (a * n1) == a]

To test, we just print the list.

main :: IO ()
main = print feinman

As expected, we get the single result of (484, 7289). Runtime is about 8.5 seconds in ghci and 60 ms compiled (You’ve got to love compilers). The end result is 11 lines of code, so a slight improvement over the scheme version.

Programming Praxis – Longest Common Subsequence

June 9, 2009

Today’s Programming Praxis problem is about finding the longest common subsequence of two sequences, and our target is 23 lines. Let’s go.

Our import:

import Data.Array

Hackage doesn’t seem to have an easily installable matrix package (hmatrix needs some C libraries), so we’re going to use an Array of Arrays to represent the grid of numbers. We’re going to define a little convenience function to access elements in the 2D array.

at :: Int -> Int -> Array Int (Array Int e) -> e
at x y a = a ! y ! x

And the longest common subsequence function itself.

lcs :: Eq a => [a] -> [a] -> [a]
lcs xs ys = reverse $ walk imax jmax where
    imax = length xs
    jmax = length ys
    ax = listArray (1, imax) xs
    ay = listArray (1, jmax) ys
    ls = listArray (0, jmax) [listArray (0, imax)
               [lcs' i j | i <- [0..imax]] | j <- [0..jmax]]

    lcs' 0 _ = 0
    lcs' _ 0 = 0
    lcs' i j | ax ! i == ay ! j = 1 + at (i-1) (j-1) ls
             | otherwise        = max (at (i-1) j ls) (at i (j-1) ls)

    walk 0 _ = []
    walk _ 0 = []
    walk i j | at (i-1) j ls == at i j ls = walk (i-1) j
             | at i (j-1) ls  < at i j ls = ax ! i : walk i (j-1)
             | otherwise                  = walk i (j-1)

And the usual test:

main :: IO ()
main = print $ lcs "programming" "praxis"

19 lines. Not much of an improvement. More importantly, the speed is far from optimal. The lcs in Data.List.LCS is considerably faster (though considerably longer). If anyone knows a better version, I’m all ears.

Strictbench 0.1

June 7, 2009

In the post ‘Forcing evaluation in Haskell‘ , I described how to fully evaluate a value to get around Haskell’s lazy evaluation. Since then, I’ve found myself using the following snippet a lot:

import Control.Parallel.Strategies
import Test.BenchPress

bench 1 . print . rnf

This snippet fully evaluates a value and prints how long it took to do so. I regularly use it on the Programming Praxis problems to see where the bottleneck lies in my algorithm.  It has the minor annoyance, however, that it prints a lot of information (min, max, mean, median, percentiles) that is all identical, because I only run it once. The reason I only run it once is that I’m typically evaluating a pure value, which means that any subsequent attempts to benchmark the evaluation time will take no time at all, since it has already been evaluated.

To solve this, I decided to write a small library to make this process easier and only print the time taken once. The result is StrictBench. A short example:

import Test.StrictBench

main = bench [1..10000000 :: Integer]

This code would give

2890.625 ms

as output. For the rest of the documentation I refer you to the Hackage page. The source code is pretty simple:

module Test.StrictBench (bench, benchDesc, time) where

import Control.Parallel.Strategies
import Test.BenchPress hiding (bench)
import Text.Printf

bench :: NFData a => a -> IO ()
bench = (putStrLn . (++ " ms") . show =<<) . time

benchDesc :: NFData a => String -> a -> IO ()
benchDesc s = (putStrLn . printf "%s: %s ms" s . show =<<) . time

time :: NFData a => a -> IO Double
time = fmap (median . fst) . benchmark 1 (return ())
       (const $ return ()) . const . putStr . (`seq` "") . rnf

Nothing complicated, but a nice convenience library that I’ll be using from now on.

Programming Praxis – Ternary Search Tries

June 5, 2009

Today’s Programming Praxis problem is about Ternary search tries, which are basically hashmaps of strings to values, but which can be faster in some cases. We have to implement the data structure and provide functions to find, insert, update and delete items and a function to convert the trie to a list. In order to match the provided solution, we will test our code by putting all the words in the bible, as well as their frequencies, into a ternary trie. Our target is 52 lines (the size of the provided solution). Let’s go.

Our imports:

import Data.Char
import qualified Data.List.Key as K
import Prelude hiding (lookup)

The data structure has two small differences from the one in the provided solution: I use a Maybe instead of the bool+value approach, since it’s more idiomatic Haskell, and the split is a list instead of a single type. The reason for this is that it makes the ternary trie far more generic: the provided solution works only for strings, because in the insert function it uses the first ASCII character  as a default. By making the split a list, I can use an empty list as the default, which means I can also define a trie with e.g. lists of Int as the key. This would not be possible with a single item, since there is no way to get a default value for an arbitrary type.
Another thing you might notice are the strictness annotations on the three branches of a node. If you omit these (as I initially did) and try to cram the bible in a trie you’re going to go through stack space like a hot knife through butter, which means the program will be terribly slow. Note that in order to see the benefit you will have to compile the program: running it in ghci will still produce a stack overflow.

data TernaryTrie k v = Empty | Node { val :: Maybe v,
    split :: [k], lb :: !(TernaryTrie k v),
    eb :: !(TernaryTrie k v), gb :: !(TernaryTrie k v) }

For lookup we have two terminating cases (an empty node is reached or the key is found). The rest is just simple recursion.

lookup :: Ord k => [k] -> TernaryTrie k v -> Maybe v
lookup _      Empty = Nothing
lookup []     t     = val t
lookup (x:xs) t     = case compare [x] $ split t of
                           GT -> lookup (x:xs) $ gb t
                           LT -> lookup (x:xs) $ lb t
                           EQ -> lookup xs     $ eb t

Insert, update and delete all follow the same pattern. To get rid of the boring ‘take the correct action for each branch’ code I factored that out into the modify function to better comply with the DRY principle.

insert :: Ord k => [k] -> v -> TernaryTrie k v -> TernaryTrie k v
insert k  v Empty = insert k v $
                    Node Nothing (take 1 k) Empty Empty Empty
insert [] v t     = t { val = Just v }
insert k  v t     = modify (flip insert v) k t

update :: Ord k => [k] -> v -> (v -> v) ->
          TernaryTrie k v -> TernaryTrie k v
update k  v _ Empty = insert k v Empty
update [] v p t     = t { val = Just . maybe v p $ val t }
update k  v p t     = modify (\x -> update x v p) k t

delete :: Ord k => [k] -> TernaryTrie k v -> TernaryTrie k v
delete _  Empty = Empty
delete [] t     = t { val = Nothing }
delete k  t     = modify delete k t

modify :: Ord k => ([k] -> TernaryTrie k v -> TernaryTrie k v) ->
                   [k] -> TernaryTrie k v -> TernaryTrie k v
modify f k t = case compare (take 1 k) (split t) of
                    LT -> t { lb = f (drop 0 k) $ lb t }
                    EQ -> t { eb = f (drop 1 k) $ eb t }
                    GT -> t { gb = f (drop 0 k) $ gb t }

And more recursion for the enlist method.

enlist :: TernaryTrie k v -> [([k], v)]
enlist = enlist' [] where
    enlist' _ Empty = []
    enlist' k t     =
        maybe [] (\v -> [(k, v)]) (val t) ++ enlist' k (lb t) ++
        enlist' (k ++ split t) (eb t) ++ enlist' k (gb t)

And we test it by finding the 25 most common words in the bible.

main :: IO ()
main = print . take 25 . reverse . K.sort snd . enlist .
       foldl (\t k -> update k 1 succ t) Empty .
       map (map toLower . filter isAlpha) . words =<<
       readFile "bible.txt"

And there we go. With 35 lines it’s not a huge reduction (although the provided solution grows by about 15 lines if you reformat it to the 65-ish character limit I use on this blog), but that was to be expected since it’s mostly basic recursion, which doesn’t easily lend itself to alternative solutions. Still, it’ll do.