from Richard Bird, "Pearls of Functional Algorithm Design"
Ch.7: Building a tree with minimum height
Trees with data written on the leaves
> data Tree a = Leaf a | Fork (Tree a) (Tree a)
> deriving (Show,Eq)
Given a list of elements, with want to create a tree with that
list as the fringe (reading the leaves from left to right)
with the minimum height
Two ways of doing it, top-down or bottom-up
> treeTD :: [a] -> Tree a
> treeTD [a] = Leaf a
> treeTD l = let (l1,l2) = splitAt (length l `div` 2) l
> in Fork (treeTD l1) (treeTD l2)
> treeBU :: [a] -> Tree a
> treeBU = fromTrs . map Leaf
> fromTrs :: [Tree a] -> Tree a
> fromTrs [t] = t
> fromTrs t = fromTrs (step t)
> where step (t1:t2:ts) = (Fork t1 t2) : (step ts)
> step ts = ts
Problem: do the same, but the leaves have a given cost
The total cost is the height plus the leaf value
data Tree Int = Leaf Int | Fork Tree Int Tree Int
deriving (Eq,Show)
> cost :: Tree Int -> Int
> cost (Leaf x) = x
> cost (Fork u v) = 1 + (cost u `max` cost v)
The most naive way, very inefficient
Construct all the possible trees and then find the minumum
trees :: [Int] -> [Tree Int]
trees [x] = [Leaf x]
trees (x:xs) = concat $ map (prefixes x) (trees xs)
prefixes :: Int -> Tree Int -> [Tree Int]
prefixes x t@(Leaf y) = [Fork (Leaf x) t]
prefixes x t@(Fork u v) = (Fork (Leaf x) t) : [Fork u' v | u' <- prefixes x u]
minBy :: (a->Int) -> [a] -> a
minBy f [a] = a
minBy f (a:as) = let a' = minBy f as
in if (f a)<=(f a') then a else a'
> mincostTree :: [Int] -> Tree Int
> mincostTree = minBy cost . trees
A generalised folding function for non-empty lists
> foldrn :: (a->b->b) -> (a->b) -> [a] -> b
> foldrn f g [x] = g x
> foldrn f g (x:xs) = f x (foldrn f g xs)
> wrap :: a -> [a]
> wrap x = [x]
One improvement can be just changing the definition of trees:
trees = foldrn (concatMap.prefixes) (wrap.Leaf)
Using forests
> type Forest = [Tree Int]
A forest represent the left spine of a tree
Its elements are the right children of each node on the spine
> rollup :: Forest -> Tree Int
> rollup = foldl1 Fork
> trees :: [Int] -> [Tree Int]
> trees = map rollup . forests
> forests :: [Int] -> [Forest]
> forests = foldrn (concatMap.prefixes) (wrap.wrap.Leaf)
> prefixes :: Int -> Forest -> [Forest]
> prefixes x ts = [Leaf x : rollup (take k ts) : drop k ts
> | k <- [1..length ts]]
> minBy f = foldl1 (cmp f)
> cmp f u v = if f u <= f v then u else v
Optimal insertion
Greedy algorithm: always insert to minimise cost
> insert :: Int -> Forest -> Forest
> insert x ts = Leaf x : split x ts
> split :: Int -> Forest -> Forest
> split _ [u] = [u]
> split x ts@(u:v:ts') = if x `max` (cost u) < (cost v)
> then ts
> else split x (Fork u v : ts')
> minCostTree :: [Int] -> Tree Int
> minCostTree = rollup . (foldrn insert (wrap.Leaf))
To prove that this algorithm is correct, we extend the cost function to forest.
The cost of a forest [t1,...,tn] is the list of costs of its trees
in reverse order: [cost tn,...,cost t1].
> forestCost :: Forest -> [Int]
> forestCost = map cost . reverse
We try to minimise the cost of a forest, in the lexicographic order.
Lexicographic order: [x1,...,xn] <= [y1,...,ym] if
x1 < y1 or
x1 = y1 and x2 < y2 or
...
x1 = y1 and ... and xn = yn.
(assuminng m>=n, otherwise ys is a sublist of xs and it is smaller).
Verify that "insert" is the optimal way to add a tree to a forest
according to the lexicographic order:
insert x ts <= u for every u in prefixes x ts
It is also true that rolling up the forests preserves the order:
If ts1 <= ts2, then cost (rollup ts1) <= cost (rollup ts2).
These properties together imply that "insert" produces the minimum tree.