IFPH Section 6.3 / Heap Tree

HeapTree.hs

module HeapTree where

data HTree a = HNull | HFork a (HTree a) (HTree a) deriving Show

hflatten :: (Ord a) => HTree a -> [a]
hflatten HNull           = []
hflatten (HFork x xt yt) = x : merge (hflatten xt) (hflatten yt)

merge :: (Ord a) => [a] -> [a] -> [a]
merge []       ys       = ys
merge m@(x:xs) []       = m
merge m@(x:xs) n@(y:ys) = if x <= y
                          then x : merge xs n
                          else y : merge m ys

levels :: [a] -> [[a]]
levels = levelsWith 1
  where levelsWith _ [] = []
        levelsWith n xs = take n xs : (levelsWith (n*2) (drop n xs))

addLayer :: [a] -> [HTree a] -> [HTree a]
addLayer xs xts = add_iter xs (xts ++ repeat HNull)
  where add_iter (y:ys) (yt0:yt1:yts) = HFork y yt0 yt1 : add_iter ys yts
        add_iter []     _             = []

mkHTrees :: [[a]] -> [HTree a]
mkHTrees = foldr addLayer [HNull]

mkHTree :: [a] -> HTree a
mkHTree = head . mkHTrees . levels

sift :: (Ord a) => a -> HTree a -> HTree a -> HTree a
sift x HNull HNull = HFork x HNull HNull
sift x (HFork y a b) HNull = if x <= y
                             then HFork x (HFork y a b) HNull
                             else HFork y (sift  x a b) HNull
sift x HNull (HFork z c d) = if x < z
                             then HFork x HNull (HFork z c d)
                             else HFork z HNull (sift  x c d)
sift x (HFork y a b) (HFork z c d)
  | x <= (y `min` z) = HFork x (HFork y a b) (HFork z c d)
  | y <= (x `min` z) = HFork y (sift  x a b) (HFork z c d)
  | z <= (x `min` y) = HFork z (HFork y a b) (sift  x c d)

heapify :: (Ord a) => HTree a -> HTree a
heapify  HNull          = HNull
heapify (HFork x xt yt) = sift x (heapify xt) (heapify yt)

mkHeap :: (Ord a) => [a] -> HTree a
mkHeap = heapify . mkHTree