Heap.hs

{-# LANGUAGE CPP #-}

-- | Pairing heap implementation of dictionary
module Data.Graph.Inductive.Internal.Heap(
    -- * Type
    Heap(..),
    prettyHeap,
    printPrettyHeap,
    -- * Operations
    empty,unit,insert,merge,mergeAll,
    isEmpty,findMin,deleteMin,splitMin,
    build, toList, heapsort
) where

import Text.Show (showListWith)

#if __GLASGOW_HASKELL__ >= 704
import Control.DeepSeq (NFData (..))
#endif

data Heap a b = Empty | Node a b [Heap a b]
     deriving (Eq, Show, Read)

#if __GLASGOW_HASKELL__ >= 704
instance (NFData a, NFData b) => NFData (Heap a b) where
  rnf Empty         = ()
  rnf (Node a b hs) = rnf a `seq` rnf b `seq` rnf hs
#endif

prettyHeap :: (Show a, Show b) => Heap a b -> String
prettyHeap = (`showsHeap` "")
  where
    showsHeap Empty             = id
    showsHeap (Node key val []) = shows key . (": "++) . shows val
    showsHeap (Node key val hs) = shows key . (": "++) . shows val
                                  .  (' ':) . showListWith showsHeap hs

printPrettyHeap :: (Show a, Show b) => Heap a b -> IO ()
printPrettyHeap = putStrLn . prettyHeap

----------------------------------------------------------------------
-- MAIN FUNCTIONS
----------------------------------------------------------------------

empty :: Heap a b
empty = Empty

unit :: a -> b -> Heap a b
unit key val = Node key val []

insert :: (Ord a) => (a, b) -> Heap a b -> Heap a b
insert (key, val) = merge (unit key val)

merge :: (Ord a) => Heap a b -> Heap a b -> Heap a b
merge h Empty = h
merge Empty h = h
merge h@(Node key1 val1 hs) h'@(Node key2 val2 hs')
    | key1<key2 = Node key1 val1 (h':hs)
    | otherwise = Node key2 val2 (h:hs')

mergeAll:: (Ord a) => [Heap a b] -> Heap a b
mergeAll []        = Empty
mergeAll [h]       = h
mergeAll (h:h':hs) = merge (merge h h') (mergeAll hs)

isEmpty :: Heap a b -> Bool
isEmpty Empty = True
isEmpty _     = False

findMin :: Heap a b -> (a, b)
findMin Empty      = error "Heap.findMin: empty heap"
findMin (Node key val _) = (key, val)

deleteMin :: (Ord a) => Heap a b -> Heap a b
deleteMin Empty             = Empty
deleteMin (Node _ _ hs) = mergeAll hs

splitMin :: (Ord a) => Heap a b -> (a,b,Heap a b)
splitMin Empty             = error "Heap.splitMin: empty heap"
splitMin (Node key val hs) = (key,val,mergeAll hs)


----------------------------------------------------------------------
-- APPLICATION FUNCTIONS, EXAMPLES
----------------------------------------------------------------------


build :: (Ord a) => [(a,b)] -> Heap a b
build = foldr insert Empty

toList :: (Ord a) => Heap a b -> [(a,b)]
toList Empty = []
toList h = x:toList r
           where (x,r) = (findMin h,deleteMin h)

heapsort :: (Ord a) => [a] -> [a]
heapsort = map fst . toList . build . map (\x->(x,x))
{-
l :: (Num a) => [a]
l  = [6,9,2,13,6,8,14,9,10,7,5]
l' = reverse l

h1  = build $ map (\x->(x,x)) l
h1' = build $ map (\x->(x,x)) l'

s1  = heapsort l
s1' = heapsort l'
-}