# Monadic and Queue-Based Tree Search

``{-# LANGUAGE PatternGuards #-}import Control.Monadimport qualified Data.Sequence as Seqimport Test.SmallCheck``

Can we define instances of `MonadPlus` whose search strategy can not be easily reproduced with a queue-based strategy? Are there queue-based strategies that cannot be implemented as instances of `MonadPlus`?

Such instances can be used to search a tree

``data Tree a = Return a | Plus (Tree a) (Tree a) deriving (Eq,Show)``

by replacing the tree constructors with monadic operations:

``searchM :: MonadPlus m => Tree a -> m asearchM (Return x) = return xsearchM (Plus s t) = searchM s `mplus` searchM t``

We want to use SmallCheck to compare search strategies so we define a `Serial` instance for trees.

``instance Serial a => Serial (Tree a) where  series   = cons1 Return \/ cons2 Plus  coseries = coseries -- not needed``

If we have an implementation of a queue, i.e., an instance of the type class `Queue`

``class Queue q where  enqueue :: a -> q a -> q a  dequeue :: q a -> Maybe (a, q a)``

then we can also search a tree by queuing its nodes:

``searchQ :: Queue q => q (Tree a) -> Tree a -> [a]searchQ q t = search (enqueue t q) where  search q = maybe [] continue (dequeue q)   continue (Return x, q) = x : search q  continue (Plus s t, q) = search (enqueue s (enqueue t q))``

# Depth First Search

Depth first search can easily be implemented with the `[]`-instance of `MonadPlus` or a `[]`-instance of `Queue`, viz., a stack:

``instance Queue [] where  enqueue = (:)  dequeue []     = Nothing  dequeue (x:xs) = Just (x,xs)``

Indeed, searching a tree with `searchM` for lists and `searchQ` for a stack yields the same results:

``prop_dfs :: Tree Bool -> Boolprop_dfs t = searchM t == searchQ [] tcheck_dfs :: IO ()check_dfs = smallCheck 4 prop_dfs``

Breadth first search can be implemented with a FIFO queue:

``instance Queue Seq.Seq where  enqueue = flip (Seq.|>)  dequeue q | Seq.EmptyL  <- Seq.viewl q = Nothing            | x Seq.:< xs <- Seq.viewl q = Just (x,xs)``

We can implement breadth first search as an instance of `MonadPlus` using matrices:

``newtype Matrix a = Matrix { unMatrix :: [[a]] }flat :: Matrix a -> [a]flat (Matrix rows) = concat rowsinstance Monad Matrix where  return x = Matrix [[x]]  Matrix m >>= f = undefined -- we don't need bindinstance MonadPlus Matrix where  mzero = Matrix []  Matrix xs `mplus` Matrix ys = Matrix ([] : merge xs ys)merge :: [[a]] -> [[a]] -> [[a]]merge []       yss      = yssmerge xss      []       = xssmerge (xs:xss) (ys:yss) = (xs++ys) : merge xss yss``

Let's check that we have indeed implemented the same strategy with the `Seq` instance of `Queue` and the `Matrix` instance of `MonadPlus`:

``prop_bfs :: Tree Bool -> Boolprop_bfs t = flat (searchM t) == searchQ Seq.empty (mirror t)check_bfs :: IO ()check_bfs = smallCheck 4 prop_bfs``

The queuing approach to breadth-first search visits the nodes of each level of a tree in reverse order, so we need to mirror the tree in order to get the same results.

``mirror :: Tree a -> Tree amirror (Return a) = Return amirror (Plus s t) = Plus (mirror t) (mirror s)``

# Interleaving

We can slightly modify the `[]`-instance of `MonadPlus` to interleave results from different subtrees.

``newtype Inter a = Inter { unInter :: [a] }instance Monad Inter where  return x = Inter (return x)  Inter xs >>= f = Inter (xs >>= unInter . f)instance MonadPlus Inter where  mzero = Inter mzero  Inter xs `mplus` Inter ys = Inter (xs `inter` ys)inter :: [a] -> [a] -> [a]inter []     ys = ysinter (x:xs) ys = x : inter ys xs``

The only difference compared to the list monad is the implementation of `mplus`.

## Challenge

Define an instance `InterQ` of `Queue` such that the property

``prop_inter :: Tree Bool -> Boolprop_inter t = unInter (searchM t) == searchQ emptyInterQ t``

holds for all values of type `Tree Bool`.

# Fair Interleaving

Oleg Kiselyov defines an instance of `MonadPlus` that can be used to fairly enumerate values of an infinite tree with better memory requirements than breadth first search.

``data Stream a = Nil | Choice a (Stream a) | Incomplete (Stream a)``

The data type for streams is similar to lists but has an additional constructor to postpone the computation of incomplete (not yet computed) streams.

``instance Monad Stream where  return x = Choice x Nil  Nil          >>= f = Nil  Choice a r   >>= f = f a `mplus` (Incomplete (r >>= f))  Incomplete i >>= f = Incomplete (i >>= f)instance MonadPlus Stream where  mzero = Nil  mplus Nil r'              = Incomplete r'  mplus (Choice a r) r'     = Choice a (mplus r' r) -- interleaving!  mplus r@(Incomplete i) r' =     case r' of      Nil          -> r      Choice b r'  -> Choice b (mplus i r')      Incomplete j -> Incomplete (mplus i j)``

The twist of this instance is the implementation of bind that is responsible for the good memory requirements. When starting with a `Tree`, bind is never called (that is why we didn't need to define it for breadth first search). Hence, good performance is only achieved when using the monadic operations directly in the computation rather than constructing a search tree first that has no occurrences of bind.

I speculate that it is difficult to define a queue-based search algorithm (that searches `Tree`s) with the same performance characteristics as search that is expressed directly in the `Stream` monad.

# Mastering the Challenge

Trying to master the challenge lead to the following attemts:

## First Try: Alternating Queue

What if we add left children to the front and right children to the back of the queue, always dequeing at the front1? We can achieve this effect by enqueing alternately at the front and the back of the queue.

``data AlterQ a = AlterQ Bool (Seq.Seq a)emptyAlterQ :: AlterQ aemptyAlterQ = AlterQ False Seq.emptyinstance Queue AlterQ where  enqueue x (AlterQ b q) = AlterQ (not b) (ins x q)   where ins = if b then flip (Seq.|>) else (Seq.<|)  dequeue (AlterQ b q)    | Seq.EmptyL  <- Seq.viewl q = Nothing    | x Seq.:< xs <- Seq.viewl q = Just (x,AlterQ b xs)``

Does it pass the tests?

``prop_alter :: Tree Bool -> Boolprop_alter t = unInter (searchM t) == searchQ emptyAlterQ tcheck_alter :: IO ()check_alter = smallCheck 4 prop_alter``

It doesn't. SmallCheck produces the following counter example:

``Plus (Plus (Return True) (Plus (Return True) (Return True)))     (Plus (Plus (Return True) (Return False)) (Return True))``

Let's examine it. We can see that all labels but one are `True`, so the single occurrence of `False` must be placed at different prositions in the compared enumerations. If we replace all labels with distinct numbers, the tree looks as follows:

``````((1 (2 3)) ((4 5) 6))
``````

With the interleaving monad, the children of the root are enumerated as `[1,2,3]` and `[4,6,5]`, which are then interleaved to produce the list `[1,4,2,6,3,5]`.

The alternating queue evolves as follows:

``````(1 (2 3)) ((4 5) 6)
1 ((4 5) 6) (2 3)
--> 1
(4 5) (2 3) 6
4 (2 3) 6 5
--> 4
2 6 5 3
``````

Unlike the interleaving monad, it produces the list `[1,4,2,6,5,3]`.

## Second Try: Toms Queue

Tom Schrijvers send me another solution that seems to work introcuding it as follows:

The code below is a bit messy still. The main idea is that the queue sort of tracks the shape of the model tree. It crucially depends on the fact that two dequeues in a row mean that a solution has been produced.

``data TreeFocus a = Init0                 | Init1 a                 | Root                 | Branch0 [NNode a]                 | Branch  a [NNode a]                 | Branch1 [NNode a]data NNode a     = VValue a                 | BBranch (NNode a) (NNode a)``
``data TomsQ a     = TomsQ (TreeFocus a)emptyTomsQ       = TomsQ Init0``
``instance Queue TomsQ where  enqueue x (TomsQ tf)        = TomsQ (enq x tf)    where enq x Init0         = Init1 x          enq x Root          = Branch0 [VValue x]          enq x (Branch0 p)   = Branch x p          enq x (Branch1 p)   = Branch0 (VValue x : p)  dequeue (TomsQ tf) = do (x,tf') <- deq tf                          return (x,TomsQ tf')    where deq Root               = mzero          deq (Init1 x)          = return (x,Root)          deq (Branch x p)       = return (x,Branch1 p)          deq (Branch1 p)        = deq (ascend p)          ascend []              = Root          ascend (x:xs)          = ascend' xs x          ascend' [] x           = descend x          ascend' (y:ys) x       = ascend' ys (BBranch y x)          descend (VValue x)     = Init1 x          descend (BBranch l r)  = descend' l [r]          descend' (VValue x) p     = Branch x p          descend' (BBranch l r) p  = descend' l (r:p)``
``prop_tomsq :: Tree Bool -> Boolprop_tomsq t = unInter (searchM t) == searchQ emptyTomsQ tcheck_tomsq :: IO ()check_tomsq = smallCheck 4 prop_tomsq``

1. Credits for this idea go to Tom Schrijvers.