[Haskell-cafe] Re: Construct all possible trees
apfelmus
apfelmus at quantentunnel.de
Wed Jun 13 05:33:50 EDT 2007
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.
More information about the Haskell-Cafe
mailing list