Word ladder in Haskell

Another followup to my earlier post about searching for word ladders, this time using Haskell!

This blog post is a Haskell program, written using the "literate comment" convention.

First a bit of front matter. This implementation of the word-ladder search will use the State and list monads.

> module Main where
> import Control.Monad.State
> import Data.Char
> import Data.List (find)
> import Data.Set (Set, member, difference)
> import qualified Data.Set as Set
> import System.Environment (getArgs)
> import System.Exit

The idea is simple: read the dictionary, search for the desired ladder, and show it to the user:

> main :: IO ()
> main = do
>   (start, goal, dict) <- getArgs >>= parse
>   fullDictionary <- readDictionary dict
>   print $ search start goal (trim fullDictionary start)

Remember that getArgs is an action that returns the list of command-line arguments. We bind this action to the following:

>   where parse [start,goal,dict] = return (start,goal,dict)
>         parse [start,goal]      = return (start,goal,"/usr/dict/words")
>         parse _ =
>           putStrLn "Usage: ladder start goal [ dictionary ]" >>
>           exitWith (ExitFailure 1)

Haskell's pattern matching shows that the program takes two or three arguments. The first two are the start and goal words. The optional third argument is the path to a dictionary (one word per line) to use.

We condition the dictionary by eliminating words whose lengths differ from the length of the start word and also converting everything to lowercase.

>         trim :: [String] -> String -> [String]
>         trim words start = filter (sameLength start) (lc words)
>
>         sameLength start = (== length start) . length
>
>         lc = map (map toLower)

The search can fail, so result is of type Maybe [String]. Handling both cases is straightforward:

>         print Nothing = putStrLn "No ladder found."
>         print (Just a) = mapM_ putStrLn a

The dictionary's format is simple, so reading it is a matter of extracting the lines from the file:

> readDictionary :: FilePath -> IO [String]
> readDictionary path = liftM lines $ readFile path

Now for the fun bits. Imagine a graph where nodes are words from the dictionary and where edges are between words that are "one hop' from each other, i.e., words that could be on consecutive "rungs" of a ladder.

Beginning with the start word, the program performs a breadth-first search of this graph. We call the set of words reached in the most recent iteration the "fringe." When the fringe contains the goal word, we're done.

The state monad simulates destructive update in imperative programming languages. (Haskell is purely functional.) Without it, we'd have to explicitly thread the state value through the call chain, but with it, we retrieve and update the state value with get and put as below:

> search start goal words =
>   evalState (loop [[start]]) (Set.fromList $ filter (/=start) words)
>   where
>     loop :: [[String]] -> State (Set String) (Maybe [String])
>     loop [] = return Nothing
>     loop paths = do
>       next <- step paths
>       let newFringe = fringe next
>       words <- get
>       put $ words `difference` newFringe
>       if goal `member` newFringe
>         then return $ Just (winner next)
>         else loop next

The list monad is handy for representing nondeterministic computations. In concept at least, the search carries around a list of lists that has all of the partial results computed so far.

For example, if the start word is dog, the state value on the second iteration might be [["dog", "dig"], ["dog", "fog"], ["dog", "bog"]]. This approach might seems to be a memory pig, but it remains surprisingly frugal.

To proceed to the next iteration of the search, for each partial result (one ladder beginning with the start word) we find the as-yet unseen neighbors of its last element (a member of the current fringe) and replace the current partial result with new ones for each of the neighbors. Again, consider the partial results at the second iteration in the previous paragraph.

>     step :: [[String]] -> State (Set String) [[String]]
>     step paths = do
>       words <- get
>       return $ paths >>= augment words
>
>     augment :: Set String -> [String] -> [[String]]
>     augment words path = [ path ++ [n] | n <- ns ]
>       where ns = Set.elems $ neighbors (last path) words
>     
>     neighbors :: String -> Set String -> Set String
>     neighbors word words = Set.filter (oneHop word) words
>       where oneHop [] [] = False
>             oneHop (x:xs) (y:ys) | x /= y = xs == ys
>                                  | otherwise = oneHop xs ys

As described above, the fringe is the set of words at the ends of the partial ladders computed so far:

>     fringe :: [[String]] -> Set String
>     fringe paths = Set.fromList (map last paths)

Once we've seen the goal in the fringe, we return the ladder that ends with the goal word:

>     winner :: [[String]] -> [String]
>     winner paths =
>       case (find ((== goal) . last) paths) of
>         Nothing -> undefined
>         Just a -> a