[Haskell-cafe] Monad for binary tree data structure

[wren ng thornton]

On 7/23/11 1:31 AM,
Александр wrote:
> Hello,
>
> I built binary tree with:
>
> data Tree a = Empty
>                | Node a (Tree a) (Tree a)
>                deriving (Eq, Ord, Read, Show)
>
> How can i make Monad type class instance for this tree? And can i make
it on not?

Of course you can. One way of thinking about monads is that it's just
performing substitution, aka tree grafting. In this case, because the
"variables" being substituted for are located within the tree, we need to
make sure to distribute the substructure of the original tree over the
result of substituting for the variable. Thus, we can define:

    data Tree a = Empty | Node a (Tree a) (Tree a)
        deriving (Eq, Ord, Read, Show)

    -- This one should be obvious.
    instance Functor Tree where
        fmap f Empty        = Empty
        fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)

    -- | The tree @graft gl gr t@ is the result of grafting @gl@ in
    -- place of all left @Empty@ leaves and @gr@ in place of all
    -- right @Empty@ leaves; with the empty tree mapped to itself.
    graft :: Tree a -> Tree a -> Tree a -> Tree a
    graft gl gr = go
        where
        go Empty                = Empty
        go (Node x Empty Empty) = Node x gl gr
        go (Node x Empty r    ) = Node x gl (go r)
        go (Node x l     Empty) = Node x (go l) gr
        go (Node x l     r    ) = Node x (go l) (go r)

    instance Monad Tree where
        return x         = Node x Empty Empty
        Empty      >>= _ = Empty
        Node x l r >>= f = graft (l >>= f) (r >>= f) (f x)

And we can verify the correctness by using QuickCheck or lazy SmallCheck:

    import Control.Monad ((<=<))
    import Test.QuickCheck

    instance Arbitrary a => Arbitrary (Tree a) where
        arbitrary = do
            b <- elements [True,False]
            if b
                then return Empty
                else do
                    x <- arbitrary
                    l <- arbitrary
                    r <- arbitrary
                    return (Node x l r)

    -- | Extensional function equality.
    (f === g) x  =  f x == g x

    prop_mapIdentity     =           fmap id === id
    prop_mapCompose f g  = (fmap f . fmap g) === fmap (f . g)

    prop_leftUnit  f     =    (return <=< f) === f
    prop_rightUnit f     =    (f <=< return) === f
    prop_assoc     f g h = (f <=< (g <=< h)) === ((f <=< g) <=< h)


Of course, there are other monads as well. In particular, for any
semigroup on A there is a monad for Tree A. For these instances we would
want to define a merging function:

    -- | The first argument is an associative operation for resolving
    -- conflicts in merging. Non-conflicts are resolved by assuming
    -- an identity element for the operation, thus lifting it into a
    -- monoid.
    merge :: (a -> a -> a) -> Tree a -> Tree a -> Tree a
    merge _ Empty tr    = tr
    merge _ tl    Empty = tl
    merge f (Node x xl xr) (Node y yl yr) =
        Node (f x y) (merge f xl yl) (merge f xr yr)

Of course, there are only two semigroups which are parametric in A, hence
there are only two more Monad instances we can define this way.

    newtype Tree2 a = T2 (Tree a)
        deriving (Eq, Ord, Read, Show)

    instance Monad Tree2 where
        return x           = T2 $ Node x Empty Empty
        T2 Empty         >>= _ = T2 Empty
        T2(Node x xl xr) >>= f =
            case f x of
            T2 Empty          -> T2 Empty
            T2 (Node y yl yr) ->
                T2 $ Node y (merge' yl (T2 xl >>= f))
                            (merge' yr (T2 xr >>= f))
            where
            merge' xs (T2 ys) = merge const xs ys

    instance Arbitrary a => Arbitrary (Tree2 a) where
        arbitrary = arbitrary >>= (return . T2)

And we can similarly define Tree3 with (flip const) in place of const. All
the other monads formed this way (with any semigroup operation in place of
const) would require using a type class for restricted monads since we
need to restrict the element type to support the semigroup operation we
want to use.

-- 
Live well,
~wren