`{-# 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 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 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)

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`

.

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`

.

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.

Trying to master the challenge lead to the following attemts:

What if we add left children to the front and right children to the back of the queue, always dequeing at the front^{1}? 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]`

.

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

Credits for this idea go to Tom Schrijvers. ↩