[Haskell-cafe] Re: Construct all possible trees

[apfelmus]

Andrew Coppin wrote:
> I'm trying to construct a function
> 
>  all_trees :: [Int] -> [Tree]
> 
> such that all_trees [1,2,3] will yield
> 
> [
> Leaf 1,
> Leaf 2,
> Leaf 3,
> Branch (Leaf 1) (Leaf 2),
> Branch (Leaf 1) (Leaf 3),
> Branch (Leaf 2) (Leaf 1),
> Branch (Leaf 2) (Leaf 3),
> Branch (Leaf 3) (Leaf 1),
> Branch (Leaf 3) (Leaf 2),
> Branch (Branch (Leaf 1) (Leaf 2)) (Leaf 3),
> Branch (Branch (Leaf 1) (Leaf 3)) (Leaf 1),
> Branch (Branch (Leaf 2) (Leaf 1)) (Leaf 3),
> Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 1),
> Branch (Branch (Leaf 3) (Leaf 1)) (Leaf 2),
> Branch (Branch (Leaf 3) (Leaf 2)) (Leaf 1),
> Branch (Leaf 1) (Branch (Leaf 2) (Leaf 3)),
> Branch (Leaf 1) (Branch (Leaf 3) (Leaf 2)),
> Branch (Leaf 2) (Branch (Leaf 1) (Leaf 3)),
> Branch (Leaf 2) (Branch (Leaf 3) (Leaf 2)),
> Branch (Leaf 3) (Branch (Leaf 1) (Leaf 2)),
> Branch (Leaf 3) (Branch (Leaf 2) (Leaf 1))
> ]

Here's a way to do this.

First, some imports and the definition of Tree.

    import Data.List
    import Control.Applicative
    import qualified Data.Foldable as Foldable
    import Data.Traversable as Traversable
    import Control.Monad.State

    data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Show)

Let's assume that someone has given us a function

 trees :: a -> [Tree a]

that builds a list of all possible trees whose leaves are all equal to
(Leaf x) where x is the argument given. In other words,

 trees 1 = [
    Leaf 1
  , Branch (Leaf 1) (Leaf 1)
  , Branch (Leaf 1) (Branch (Leaf 1) (Leaf 1))
  , Branch (Branch (Leaf 1) (Leaf 1)) (Leaf 1)
  , Branch (Leaf 1) (Branch (Leaf 1) (Branch (Leaf 1) (Leaf 1)))
  , ... ]

Is this of any use? It is, the idea is to not put single elements into
the leaves, but something more clever. For instance, we can put the list
itself into the leaves

 trees [1,2,3] :: [Tree [Int]]

Now, we can view the inner list as a monad. Thus, we have a tree of
nondeterministic values but want to have a nondeterministic tree. Can we
flatten it somehow?

 ? :: Tree [a] -> [Tree a]

Indeed we can, for this is nothing more than a generalization of the
well-known

 sequence :: Monad m => [m a] -> m [a]

from lists to trees:

 sequence :: Monad m => Tree (m a) -> m (Tree a)

Setting  m a = [a]  then gives the desired

 sequence :: Tree [a] -> [Tree a]

In fact, the generalization works for many types and the pattern behind
is captured by applicative functors and Data.Traversable.

    instance Traversable Tree where
        traverse f (Leaf a)     = Leaf <$> f a
        traverse f (Branch x y) =
           Branch <$> traverse f x <*> traverse f y

    instance Functor Tree where
        fmap = fmapDefault

    instance Foldable.Foldable Tree where
        foldMap = foldMapDefault

Explaining how this works exactly would explode this mail, but the
haddocks for Data.Traversable are a good start to learn more. What
counts is that we now have

 Traversable.sequence :: Monad m => Tree (m a) -> m (Tree a)

for free and we can formulate our idea

        -- all possible trees whose leaves are from the given list
    mutlisetTrees :: [a] -> [Tree a]
    mutlisetTrees xs = concatMap Traversable.sequence $ trees xs

This gives

 mutlisetTrees [1,2,3] = [
    Leaf 1
  , Leaf 2
  , Leaf 3
  , Branch (Leaf 1) (Leaf 1)
  , Branch (Leaf 1) (Leaf 2)
  , Branch (Leaf 1) (Leaf 3)
  , Branch (Leaf 2) (Leaf 1)
  , Branch (Leaf 2) (Leaf 2)
  , Branch (Leaf 2) (Leaf 3)
  , Branch (Leaf 3) (Leaf 1)
  , Branch (Leaf 3) (Leaf 2)
  , Branch (Leaf 3) (Leaf 3)
  , Branch (Leaf 1) (Branch (Leaf 1) (Leaf 1))
  , ...]

A good try, but this gives all combinations of elements from [1,2,3].
This was to be expected, because

   do
    x <- [1,2,3]
    y <- [1,2,3]
    return (x,y)

analogously gives all pairs [(1,1),(1,2),(1,3),(2,1),...].

How to make permutations out of this? The idea is to incorporate state
into our monad, namely the list of elements not yet used. Every time we
generate a new nondeterministic value, we choose it from this list and
supply all subsequent monadic action a list where this value is removed.
 Here's the code:

        -- all possible trees whose leaves are
        -- a permutation of the given list
    permTrees :: [a] -> [Tree a]
    permTrees xs = concat . takeWhile (not . null) . map
        (flip evalStateT xs . Traversable.sequence) $ trees select
        where
        select = StateT $ \xs ->
            [(z,ys++zs) | (ys,z:zs) <- zip (inits xs) (tails xs)]

    all_trees = permTrees

Instead of putting [1,2,3] into the leaves of our trees, we put a
monadic action called "select" in there. We can put state on top of the
list monad with the StateT monad transformer so that "select" has the type

 select :: StateT [a] [] a



Now, all that remains is to implement  trees. For that, we note that a
tree with n leaves always has the form

 n leaves = Branch (k leaves) (n-k leaves)

for some k. This reminds us of the multiplication of power series and
hints that we should build a list

 trees = [1 leaves, 2 leaves, 3 leaves, 4 leaves, ...]

which is equal to

  = [1 leaves
    , [Branch (1 leaves, 1 leaves)]
    , [Branch (1 leaves, 2 leaves), Branch (2 leaves, 1 leaves)]
    , .. (1 .. 3) .. (2 .. 2) .. (3 .. 1)
    , ... ]

Now, we can get the (k leaves) recursively from trees itself!

        -- all possible trees with leaves all equal to (Leaf x)
    trees :: a -> [Tree a]
    trees x = ts
        where ts = concat $ ([Leaf x] :) $ convolution Branch ts ts

Here, "convolution" pairs the (k leaves) and (n-k leaves). For example,

 convolution (*) [x1,x2,x3] [y1,y2,y3]
  == [[x1*y1)],[x1*y2, x2*y1],[x1*y3, x2*y2, x3*y1]]

It's implemented as

    convolution :: (a -> a -> b) -> [a] -> [a] -> [[b]]
    convolution f xs ys = tail $
        zipWith (zipWith f) (inits' xs) $ scanl (flip (:)) [] ys

The implementation here closely follows the "Method of the sliding bars"
for the multiplication of power series as coined in my old math book.


There is a small problem in the recursive definition of trees, namely
that it only works if "convolution" is lazy enough. Unfortunately, the
Prelude function "inits" is *too strict*

 inits (1:_|_) == []:_|_

and not

 inits (1:_|_) == []:[1]:_|_

as one would expect. I think that this counts as bug in the Prelude.
Here's a correct definition

    inits' xs = []:case xs of
        []     -> []
        (x:xs) -> map (x:) $ inits' xs


Regards,
apfelmus

PS: There is at least one other way to solve the problem. It works by
generating all permutations first and parsing the resulting permutations
in all possible ways as trees.

PSS: A naive parsing algorithm is not as efficient as it good be because
parses from different permutations can be reused for parsing larger
ones. Note that the same observation carries over to the algorithm
presented here, and I'm not sure, but I think it does the sharing.