Breadth-First Search, State Monad, explicit queue, and Lenses.

bfs-state-monad.hs

{-#LANGUAGE TemplateHaskell #-}

import Control.Lens
import Control.Monad.State

data Tree a = Node a
            | Branch a (Tree a) (Tree a)

childrenOf (Node _)       = []
childrenOf (Branch _ l r) = [l, r]
valueOf (Node a)       = a
valueOf (Branch a _ _) = a

tree1 :: Tree Integer
tree1 = Branch 1
          (Branch 2
            (Node 4)
            (Node 5))     -- Depth 3
          (Branch 3
            (Node 6)
            (Node 7))

tree2 :: Tree Integer
tree2 = Branch 1
          (Branch 2
            (Branch 4
              (Branch 6
                (Node 8)
                (Node 9)) -- Depth 5
              (Node 7))
            (Node 5))
          (Node 3)

-- Breadth-First Search State
data BFS a = BFS { _queue    :: [Tree a]
                 , _results  :: [a]
                 , _backward :: Bool }

makeLenses ''BFS

toBFS tree = BFS [tree] [] False

bfs :: State (BFS a) [a]
bfs = do
  nodes <- use queue
  if null nodes then
    use results
  else do
    forward <- backward <%= not
    queue .= []
    rs <- forM nodes $ \node -> do
      queue <>= childrenOf node
      return $ valueOf node
    when   forward $    results <>= reverse rs
    unless forward $ do results <>=         rs
                        queue    %= reverse
    bfs

flat1 = evalState bfs $ toBFS tree1
flat2 = evalState bfs $ toBFS tree2