There was an interesting paper on deriving the algorithm as a result of applying fully-lazy evaluation and memoization on a more naive algorithm. Unfortunately, applying fully-lazy evaluation and memoization to a function in Haskell is non-trivial (despite it being theoretically possible for the compiler to do so!).

It’s always interesting trying to find the functional equivalent to an imperative algorithm. I ended up using some cute Haskell tricks.

Update: I’ve written an improved version of Aho-Corasick implemented with Data.Array and Data.Map

Instead of a BFS to compute the failure function, I propagate a recursive function forward as the trie is constructed. The separate mkRoot provides the base case with which to tie-the-knot.

mkRoot xs = let root = Root (edge [] (sort xs) root) in root
mkTrie prefix f xs = Node goto prefix ((not.null) self) f
  where
    goto = edge prefix kids =<< (failTo f)
    (self, kids) = if null (head xs) then ([head xs], tail xs) else ([], xs)

Instead of using a list to implement the branches of a rose tree, I used partial-application over edge. This certainly looks elegant, but in fact it is the weak point, as withPrefix is a linear search; the imperative approach is an O(1) lookup (with small alphabets) or O(log m) over m branches. Furthermore, the lazy evaluation of edge means that the trie is being constantly reconstructed as it is traversed by the automaton.

data Trie = Node (Char -> Maybe Trie) String Bool Trie
          | Root (Char -> Maybe Trie)

edge :: String -> [String] -> Trie -> Char -> Maybe Trie
edge prefix xs f c =
  if null (withPrefix c)
  then Nothing
  else Just (mkTrie (c:prefix) f (map tail (withPrefix c)))
  where
    withPrefix c = takeWhile ((c==) . head) . dropWhile ((c>) . head) $ xs

Obviously it’s not generic over types or anything, but it should work fine with lists of types other than Char.

The following pathological case didn’t run too badly (25 seconds for m=50, n=100000 on scud, compiled with ghc -O2). Profiling it revealed 20 million entries into edge; which easily dominates the timing. Oddly enough this just seems to be a large constant—other samples suggest it’s linear in the product m n.

main = do
  args <- getArgs
  let
    (m:n:_) = map (fst . head . readDec) args
    patterns = (take m . tails . concat . take 25 . repeat) "ab"
    haystack = (concat . take n . repeat) "ab"
  putStr $ show (length (findMatches patterns haystack))

It was fun revisiting Haskell, and writing parsers directly using Parsec is certainly a novel alternative to using a Bison-style compiler-compiler. Spirit was similar, but C++ can become so syntactically clunky some of the joy is lost.

I’m not sure whether it was something specific to the Parsec paradigm, my abuse of Parsec, or my ignorance of Haskell and monadic programming in general, but I kept finding myself on the wrong side of Monads and do-expressions. It seems you have to use liftM a lot.

In looking for a generalisation of the liftMn functions I came up with:

foldMLr :: (Monad m) => (t -> a -> a) -> a -> [m t] -> m a
-- foldMLr f u xs binds the monads in xs headfirst, and folds their results
-- from the right using f and u as the rightmost.
foldMLr _ u [] = return u
foldMLr f u (x:xs) = do { a <- x ; b <- foldMLr f u xs ; return (f a b) }
-- equivalently:
-- foldMLr f u (x:xs) = liftM2 f x (foldMLr f u xs)

which is not the same as foldM but is a generalisation of sequence, which can be defined as foldMLr (:) []. I didn’t end up using it in the final parser.

Another issue was that constructing a parse tree (using Data.Tree types) was actually somewhat tedious. I guess Parsec assumes that you want to fold up the result within the parsers.

Also watch out for the change in showErrorMessages, in ghc it takes some extra initial string arguments that weren’t there in the standalone release.