Monadic and Queue-Based Tree Search





import Control.Monad

import qualified Data.Sequence as Seq

import 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 a

searchM (Return x) = return x

searchM (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



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 -> Bool

prop_dfs t = searchM t == searchQ [] t



check_dfs :: IO ()

check_dfs = smallCheck 4 prop_dfs



Breadth First Search

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 rows



instance Monad Matrix

where

return x = Matrix [[x]]



Matrix m >>= f = undefined



instance MonadPlus Matrix

where

mzero = Matrix []



Matrix xs `mplus` Matrix ys = Matrix ([] : merge xs ys)



merge :: [[a]] -> [[a]] -> [[a]]

merge [] yss = yss

merge xss [] = xss

merge (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 -> Bool

prop_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 a

mirror (Return a) = Return a

mirror (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 = ys

inter (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 -> Bool

prop_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)

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 front ? 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 a

emptyAlterQ = AlterQ False Seq.empty



instance 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 -> Bool

prop_alter t = unInter (searchM t) == searchQ emptyAlterQ t



check_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)

