2*n+h n Solution for Breadth-First Numbering (Okasaki paper)

data Tree a = Tree a (Tree a) (Tree a) | Leaf a | EmptyLeaf
 deriving (Show,Eq)

renameTreeNodes :: (Tree a) -> [Int] -> (Tree Int)
renameTreeNodes tree counts     = fst $ renameLoop tree counts
 where
 renameLoop EmptyLeaf   cs    = (EmptyLeaf, cs)
 renameLoop (Leaf _)   (c:cs)   = (Leaf c, (c+1):cs)
 renameLoop (Tree _ lb rb) (c:cs)   = (Tree c lb' rb', (c+1):csLR)
  where
  (lb',csL) = renameLoop lb cs
  (rb',csLR) = renameLoop rb csL

countsToBases :: [Int] -> [Int]
countsToBases cs = ctbLoop cs 1
 where
 ctbLoop [c] b  = [b]
 ctbLoop (c:cs) b = b:ctbLoop cs (b + c)

countOnEachLevel :: (Tree a) -> [Int]
countOnEachLevel tree = countLoop tree []
 where
 countLoop EmptyLeaf counts = counts
 countLoop (Leaf _) (c:cs) = (c+1):cs
 countLoop tree []  = countLoop tree [0]
 countLoop (Tree _ leftBranch rightBranch) (c:cs) = (c+1):csLR
  where
  csL = countLoop leftBranch cs
  csLR = countLoop rightBranch csL

---

Amazingly improved by BlackMeph

main = print . renameTreeNodes $ testTree

renameTreeNodes :: Tree a -> Tree Int
renameTreeNodes tree = t' where
    (t',ks) = renameLoop tree (1:ks)
    renameLoop EmptyLeaf cs = (EmptyLeaf,cs)
    renameLoop (Leaf _) (c:cs) = (Leaf c,(c+1):cs)
    renameLoop (Tree _ lb rb) (c:cs) = (Tree c lb' rb',(c+1):csLR) where
       (lb',csL)  = renameLoop lb cs
       (rb',csLR) = renameLoop rb csL

Source at HPASTE