Monadic and Queue-Based Tree Search

{-# LANGUAGE PatternGuards #-}

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 -- 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 -> 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 -- we don't need bind

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) -- 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 Trees) 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 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)
prop_tomsq :: Tree Bool -> Bool
prop_tomsq t = unInter (searchM t) == searchQ emptyTomsQ t

check_tomsq :: IO ()
check_tomsq = smallCheck 4 prop_tomsq

  1. Credits for this idea go to Tom Schrijvers.