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.