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.