How to functionally generate a tree breadth-first. (With Haskell)

Question

Say I have the following Haskell tree type, where "State" is a simple wrapper:

data Tree a = Branch (State a) [Tree a]
            | Leaf   (State a)
            deriving (Eq, Show)

I also have a function "expand :: Tree a -> Tree a" which takes a leaf node, and expands it into a branch, or takes a branch and returns it unaltered. This tree type represents an N-ary search-tree.

Searching depth-first is a waste, as the search-space is obviously infinite, as I can easily keep on expanding the search-space with the use of expand on all the tree's leaf nodes, and the chances of accidentally missing the goal-state is huge... thus the only solution is a breadth-first search, implemented pretty decent over here, which will find the solution if it's there.

What I want to generate, though, is the tree traversed up to finding the solution. This is a problem because I only know how to do this depth-first, which could be done by simply called the "expand" function again and again upon the first child node... until a goal-state is found. (This would really not generate anything other then a really uncomfortable list.)

Could anyone give me any hints on how to do this (or an entire algorithm), or a verdict on whether or not it's possible with a decent complexity? (Or any sources on this, because I found rather few.)

Answer 1

I'm curious why you need the expand function at all--why not simply construct the entire tree recursively and perform whatever search you want?

If you're using expand in order to track which nodes are examined by the search, building a list as you go seems simpler, or even a second tree structure.

Here's a quick example that just returns the first result it finds, with the spurious Leaf constructor removed:

data State a = State { getState :: a } deriving (Eq, Show)

data Tree a = Branch { 
    state :: State a, 
    children :: [Tree a]
    } deriving (Eq, Show)

breadth ts = map (getState . state) ts ++ breadth (concatMap children ts)
search f t = head $ filter f (breadth [t])

mkTree n = Branch (State n) (map mkTree [n, 2*n .. n*n])

testTree = mkTree 2

Trying it out in GHCi:

> search (== 24) testTree
24

For contrast, here's a naive depth-first search:

depth (Branch (State x) ts) = x : (concatMap depth ts)
dSearch f t = head $ filter f (depth t)

...which of course fails to terminate when searching with (== 24), because the left-most branches are an endless series of 2s.

Answer 2

Have you looked at Chris Okasaki's "Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design"? The Data.Tree module includes a monadic tree builder named unfoldTreeM_BF that uses an algorithm adapted from that paper.

Here's an example that I think corresponds to what you're doing:

Suppose I want to search an infinite binary tree of strings where all the left children are the parent string plus "a", and the right children are the parent plus "bb". I could use unfoldTreeM_BF to search the tree breadth-first and return the searched tree up to the solution:

import Control.Monad.State
import Data.Tree

children :: String -> [String]
children x = [x ++ "a", x ++ "bb"]

expand query x = do
  found <- get
  if found
    then return (x, [])
    else do
      let (before, after) = break (==query) $ children x
      if null after
        then return (x, before)
        else do
          put True
          return (x, before ++ [head after])

searchBF query = (evalState $ unfoldTreeM_BF (expand query) []) False

printSearchBF = drawTree . searchBF

This isn't terribly pretty, but it works. If I search for "aabb" I get exactly what I want:

|
+- a
|  |
|  +- aa
|  |  |
|  |  +- aaa
|  |  |
|  |  `- aabb
|  |
|  `- abb
|
`- bb
   |
   +- bba
   |
   `- bbbb

If this is the kind of thing you're describing, it shouldn't be hard to adapt for your tree type.

UPDATE: Here's a do-free version of expand, in case you're into this kind of thing:

expand q x = liftM ((,) x) $ get >>= expandChildren
  where
    checkChildren (before, [])  = return before
    checkChildren (before, t:_) = put True >> return (before ++ [t])

    expandChildren True  = return []
    expandChildren _     = checkChildren $ break (==q) $ children x

(Thanks to camccann for prodding me away from old control structure habits. I hope this version is more acceptable.)