{-# 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
(Heap a b -> Heap a b -> Bool)
-> (Heap a b -> Heap a b -> Bool) -> Eq (Heap a b)
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
[Heap a b] -> ShowS
Heap a b -> String
(Int -> Heap a b -> ShowS)
-> (Heap a b -> String) -> ([Heap a b] -> ShowS) -> Show (Heap a b)
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)
Int -> ReadS (Heap a b)
ReadS [Heap a b]
(Int -> ReadS (Heap a b))
-> ReadS [Heap a b]
-> ReadPrec (Heap a b)
-> ReadPrec [Heap a b]
-> Read (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) = a -> ()
forall a. NFData a => a -> ()
rnf a
a () -> () -> ()
`seq` b -> ()
forall a. NFData a => a -> ()
rnf b
b () -> () -> ()
`seq` [Heap a b] -> ()
forall a. NFData a => a -> ()
rnf [Heap a b]
hs
#endif

prettyHeap :: (Show a, Show b) => Heap a b -> String
prettyHeap :: Heap a b -> String
prettyHeap = (Heap a b -> ShowS
forall a a. (Show a, Show a) => Heap a a -> ShowS
`showsHeap` String
"")
  where
    showsHeap :: Heap a a -> ShowS
showsHeap Heap a a
Empty             = ShowS
forall a. a -> a
id
    showsHeap (Node a
key a
val []) = a -> ShowS
forall a. Show a => a -> ShowS
shows a
key ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
val
    showsHeap (Node a
key a
val [Heap a a]
hs) = a -> ShowS
forall a. Show a => a -> ShowS
shows a
key ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
val
                                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Heap a a -> ShowS) -> [Heap a a] -> ShowS
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 :: Heap a b -> IO ()
printPrettyHeap = String -> IO ()
putStrLn (String -> IO ()) -> (Heap a b -> String) -> Heap a b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Heap a b -> String
forall a b. (Show a, Show b) => Heap a b -> String
prettyHeap

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

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

unit :: a -> b -> Heap a b
unit :: a -> b -> Heap a b
unit a
key b
val = a -> b -> [Heap a b] -> Heap a b
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 :: (a, b) -> Heap a b -> Heap a b
insert (a
key, b
val) = Heap a b -> Heap a b -> Heap a b
forall a b. Ord a => Heap a b -> Heap a b -> Heap a b
merge (a -> b -> Heap a b
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 :: 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
key1a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
key2 = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
key1 b
val1 (Heap a b
h'Heap a b -> [Heap a b] -> [Heap a b]
forall a. a -> [a] -> [a]
:[Heap a b]
hs)
    | Bool
otherwise = a -> b -> [Heap a b] -> Heap a b
forall a b. a -> b -> [Heap a b] -> Heap a b
Node a
key2 b
val2 (Heap a b
hHeap a b -> [Heap a b] -> [Heap a b]
forall a. a -> [a] -> [a]
:[Heap a b]
hs')

mergeAll:: (Ord a) => [Heap a b] -> Heap a b
mergeAll :: [Heap a b] -> Heap a b
mergeAll []        = Heap a b
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) = Heap a b -> Heap a b -> Heap a b
forall a b. Ord a => Heap a b -> Heap a b -> Heap a b
merge (Heap a b -> Heap a b -> Heap a b
forall a b. Ord a => Heap a b -> Heap a b -> Heap a b
merge Heap a b
h Heap a b
h') ([Heap a b] -> Heap a b
forall a b. Ord a => [Heap a b] -> Heap a b
mergeAll [Heap a b]
hs)

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

findMin :: Heap a b -> (a, b)
findMin :: Heap a b -> (a, b)
findMin Heap a b
Empty      = String -> (a, b)
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 :: Heap a b -> Heap a b
deleteMin Heap a b
Empty             = Heap a b
forall a b. Heap a b
Empty
deleteMin (Node a
_ b
_ [Heap a b]
hs) = [Heap a b] -> Heap a b
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 :: Heap a b -> (a, b, Heap a b)
splitMin Heap a b
Empty             = String -> (a, b, Heap a b)
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,[Heap a b] -> Heap a b
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 :: [(a, b)] -> Heap a b
build = ((a, b) -> Heap a b -> Heap a b)
-> Heap a b -> [(a, b)] -> Heap a b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, b) -> Heap a b -> Heap a b
forall a b. Ord a => (a, b) -> Heap a b -> Heap a b
insert Heap a b
forall a b. Heap a b
Empty

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

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