BHeap

module BinomialHeap
   (
      BinHeap,
      insert,
      merge,
      extractMin,
      deleteMin,
      binHeapSort,
      fromList,
      toSortedList,

      heapMap,
      heapFoldr,
      heapFoldl,
      heapFilter
   ) where

import BinomialTree

data (Eq a, Ord a) => BinHeap a = BHeap [BinTree a] deriving (Show)

extractMin :: Ord a => BinHeap a -> a
extractMin (BHeap h) = foldl min (key (head h)) (map key h)

merge :: Ord a => BinHeap a -> BinHeap a -> BinHeap a
merge (BHeap h1) (BHeap h2) = BHeap (mergeHeaps h1 h2)

headRank :: Ord a => [BinTree a] -> Int
headRank [] = 0
headRank (hd:_) = rank hd

mergeHeaps :: Ord a => [BinTree a] -> [BinTree a] -> [BinTree a]
mergeHeaps [] h = h
mergeHeaps h [] = h
mergeHeaps h1@(t1:h1') h2@(t2:h2') =
   if rank t1 < rank t2 then
      t1 : mergeHeaps h1' h2
   else if rank t2 < rank t1 then
      t2 : mergeHeaps h1 h2'
   else
      let {
         merged = mergeTrees t1 t2;
         r = rank merged
      } in
         if r /= headRank h1' then
            if r /= headRank h2' then
               merged : mergeHeaps h1' h2'
            else
               mergeHeaps (merged : h1') h2'
         else
            if r /= headRank h2' then
               mergeHeaps h1' (merged : h2')
            else
               merged : mergeHeaps h1' h2'

singleton :: (Ord a) => a -> BinHeap a
singleton k = BHeap [createTree k 1 []]

insert :: Ord a => a -> BinHeap a -> BinHeap a
insert a (BHeap h) = merge (BHeap h) (singleton a)

deleteMin :: Ord a => BinHeap a -> BinHeap a
deleteMin (BHeap h) = BHeap (deleteRootByKey (extractMin (BHeap h)) [] h)

deleteRootByKey :: (Ord a, Eq a) => a -> [BinTree a] -> [BinTree a] -> [BinTree a]
deleteRootByKey k f t@(hd:tl) =
   if (key hd == k) then
      mergeHeaps (f ++ tl) (children hd)
   else
      deleteRootByKey k (hd : f) tl

fromList :: Ord a => [a] -> BinHeap a
fromList [] = BHeap []
fromList a = foldl merge (BHeap []) (map singleton a)

toSortedList :: Ord a => BinHeap a -> [a]
toSortedList (BHeap []) = []
toSortedList h = extractMin h : toSortedList (deleteMin h)

binHeapSort :: Ord a => [a] -> [a]
binHeapSort [] = []
binHeapSort a = toSortedList (fromList a)

heapMap :: (Ord a, Ord b) => (a -> b) -> BinHeap a -> BinHeap b
heapMap f h = fromList (map f (toSortedList h))

heapFoldr :: Ord a => (a -> b -> b) -> b -> BinHeap a -> b
heapFoldr _ z (BHeap []) = z
heapFoldr f z (BHeap (hd:tl)) = heapFoldr f (treeFoldr f z hd) (BHeap tl)

heapFoldl :: Ord a => (b -> a -> b) -> b -> BinHeap a -> b
heapFoldl _ z (BHeap []) = z
heapFoldl f z (BHeap (hd:tl)) = treeFoldl f (heapFoldl f z (BHeap tl)) hd

heapFilter :: Ord a => (a -> Bool) -> BinHeap a -> BinHeap a
heapFilter f h = fromList(filter f (toSortedList h))