{-# 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 MIN_VERSION_containers (0,4,2)
import Control.DeepSeq (NFData (..))
#endif

data Heap a b = Empty | Node a b [Heap a b]
     deriving (Heap a b -> Heap a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => Heap a b -> Heap a b -> Bool
/= :: Heap a b -> Heap a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => Heap a b -> Heap a b -> Bool
== :: Heap a b -> Heap a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => Heap a b -> Heap a b -> Bool
Eq, Int -> Heap a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Heap a b -> ShowS
forall a b. (Show a, Show b) => [Heap a b] -> ShowS
forall a b. (Show a, Show b) => Heap a b -> String
showList :: [Heap a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Heap a b] -> ShowS
show :: Heap a b -> String
$cshow :: forall a b. (Show a, Show b) => Heap a b -> String
showsPrec :: Int -> Heap a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Heap a b -> ShowS
Show, ReadPrec [Heap a b]
ReadPrec (Heap a b)
ReadS [Heap a b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [Heap a b]
forall a b. (Read a, Read b) => ReadPrec (Heap a b)
forall a b. (Read a, Read b) => Int -> ReadS (Heap a b)
forall a b. (Read a, Read b) => ReadS [Heap a b]
readListPrec :: ReadPrec [Heap a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [Heap a b]
readPrec :: ReadPrec (Heap a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (Heap a b)
readList :: ReadS [Heap a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [Heap a b]
readsPrec :: Int -> ReadS (Heap a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (Heap a b)
Read)

#if MIN_VERSION_containers (0,4,2)
instance (NFData a, NFData b) => NFData (Heap a b) where
  rnf :: Heap a b -> ()
rnf Heap a b
Empty         = ()
  rnf (Node a
a b
b [Heap a b]
hs) = forall a. NFData a => a -> ()
rnf a
a seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf b
b seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf [Heap a b]
hs
#endif

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

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

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

empty :: Heap a b
empty :: forall a b. Heap a b
empty = forall a b. Heap a b
Empty

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

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

merge :: (Ord a) => Heap a b -> Heap a b -> Heap a b
merge :: forall a b. Ord a => Heap a b -> Heap a b -> Heap a b
merge Heap a b
h Heap a b
Empty = Heap a b
h
merge Heap a b
Empty Heap a b
h = Heap a b
h
merge h :: Heap a b
h@(Node a
key1 b
val1 [Heap a b]
hs) h' :: Heap a b
h'@(Node a
key2 b
val2 [Heap a b]
hs')
    | a
key1forall a. Ord a => a -> a -> Bool
<a
key2 = forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
key1 b
val1 (Heap a b
h'forall a. a -> [a] -> [a]
:[Heap a b]
hs)
    | Bool
otherwise = forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
key2 b
val2 (Heap a b
hforall a. a -> [a] -> [a]
:[Heap a b]
hs')

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

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

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

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

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


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


build :: (Ord a) => [(a,b)] -> Heap a b
build :: forall a b. Ord a => [(a, b)] -> Heap a b
build = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. Ord a => (a, b) -> Heap a b -> Heap a b
insert forall a b. Heap a b
Empty

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

heapsort :: (Ord a) => [a] -> [a]
heapsort :: forall a. Ord a => [a] -> [a]
heapsort = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => Heap a b -> [(a, b)]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ord a => [(a, b)] -> Heap a b
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\a
x->(a
x,a
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'
-}