summaryrefslogtreecommitdiff
path: root/Data/Heap
diff options
context:
space:
mode:
Diffstat (limited to 'Data/Heap')
-rw-r--r--Data/Heap/Binary.hs76
-rw-r--r--Data/Heap/Binomial.hs106
-rw-r--r--Data/Heap/Skew.hs63
3 files changed, 245 insertions, 0 deletions
diff --git a/Data/Heap/Binary.hs b/Data/Heap/Binary.hs
new file mode 100644
index 0000000..c9bd084
--- /dev/null
+++ b/Data/Heap/Binary.hs
@@ -0,0 +1,76 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+-- | 'Data.Heap.Binary' provides a binary min-heap. Balance is maintained through descendant counting.
+module Data.Heap.Binary
+(BinaryHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert)
+where
+
+import Prelude hiding (head, tail, null)
+
+data (Ord n) => BinaryHeap n =
+ Leaf
+ | Node n Int (BinaryHeap n) (BinaryHeap n) deriving (Eq, Ord)
+
+instance (Ord n, Show n) => Show (BinaryHeap n) where
+ show Leaf = "Leaf"
+ show (Node n _ h1 h2) = "Node " ++ (show n) ++ " (" ++ (show h1) ++ " " ++ (show h2) ++ ")"
+
+rank :: (Ord n) => BinaryHeap n -> Int
+rank Leaf = 0
+rank (Node _ d _ _) = d
+
+-- | /O(1)/. 'empty' produces an empty heap.
+empty :: (Ord a) => BinaryHeap a
+empty = Leaf
+
+-- | /O(1)/. 'singleton' consumes an element and constructs a singleton heap.
+singleton :: (Ord a) => a -> BinaryHeap a
+singleton a = Node a 1 Leaf Leaf
+
+-- | 'merge' consumes two binary heaps and merges them.
+merge :: (Ord a) => BinaryHeap a -> BinaryHeap a -> BinaryHeap a
+merge Leaf n = n
+merge n Leaf = n
+merge h1@(Node n1 d1 h1l h1r) h2@(Node _ d2 _ _) =
+ if head h1 == head h2 || h1 <= h2
+ then if rank h1l < rank h1r
+ then (Node n1 (d1 + d2) (merge h1l h2) h1r)
+ else (Node n1 (d1 + d2) h1l (merge h1r h2))
+ else merge h2 h1
+
+-- | /O(lg n)/.
+insert :: (Ord a) => BinaryHeap a -> a -> BinaryHeap a
+insert h a = merge h (singleton a)
+
+-- | /O(1)/.
+null :: (Ord a) => BinaryHeap a -> Bool
+null Leaf = True
+null _ = False
+
+-- | /O(n lg n)/.
+toList :: (Ord a) => BinaryHeap a -> [a]
+toList Leaf = []
+toList h@(Node _ _ _ _) = (head h):(toList $ tail h)
+
+-- | /O(n)/. 'fromList' constructs a binary heap from an unsorted list.
+fromList :: (Ord a) => [a] -> BinaryHeap a
+fromList [] = Leaf
+fromList l = (\ ((hd:_):_) -> hd) $! dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $ map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a]
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a
+
+-- | /O(1)/. 'head' returns the element root of the heap.
+head :: (Ord a) => BinaryHeap a -> a
+head Leaf = error "Data.Tree.Heap: empty list"
+head (Node n _ _ _) = n
+
+-- | /O(lg n)/. 'tail' discards the root of the heap and merges the subtrees.
+tail :: (Ord a) => BinaryHeap a -> BinaryHeap a
+tail Leaf = error "Data.Heap empty list"
+tail (Node _ _ h1 h2) = merge h1 h2
diff --git a/Data/Heap/Binomial.hs b/Data/Heap/Binomial.hs
new file mode 100644
index 0000000..f705789
--- /dev/null
+++ b/Data/Heap/Binomial.hs
@@ -0,0 +1,106 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+module Data.Heap.Binomial
+(BinomialHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert)
+where
+
+import Prelude hiding (head, tail, null)
+import Data.List (delete)
+
+data (Ord a, Ord b, Eq a, Eq b) => HeapNode a b = HeapNode a Int [b]
+
+data (Ord a, Eq a) => BinomialHeap a =
+ EmptyHeap
+ | Heap [HeapNode a (BinomialHeap a)] deriving (Eq, Ord)
+
+instance (Ord a, Ord b, Eq a, Eq b) => Ord (HeapNode a b) where
+ compare (HeapNode e1 _ _) (HeapNode e2 _ _) = compare e1 e2
+
+instance (Ord a, Ord b, Eq a, Eq b) => Eq (HeapNode a b) where
+ (HeapNode e1 _ _) == (HeapNode e2 _ _) = e1 == e2
+
+rank :: (Ord a, Ord b, Eq a, Eq b) => HeapNode a b -> Int
+rank (HeapNode _ n _) = n
+
+hRank :: (Ord a, Ord b, Eq a, Eq b) => [HeapNode a b] -> Int
+hRank [] = 0
+hRank (hd:_) = rank hd
+
+extract :: (Ord a, Ord b, Eq a, Eq b) => HeapNode a b -> a
+extract (HeapNode n _ _) = n
+
+empty :: (Ord a) => BinomialHeap a
+empty = EmptyHeap
+
+null :: (Ord a) => BinomialHeap a -> Bool
+null EmptyHeap = True
+null _ = False
+
+-- | /O(1)/.
+singleton :: (Ord a) => a -> BinomialHeap a
+singleton n = Heap [HeapNode n 1 []]
+
+-- | /O(lg n)/
+insert :: (Ord a) => BinomialHeap a -> a -> BinomialHeap a
+insert h n = merge (singleton n) h
+
+-- | /O(lg n)/.
+merge :: (Ord a) => BinomialHeap a -> BinomialHeap a -> BinomialHeap a
+merge EmptyHeap n = n
+merge n EmptyHeap = n
+merge (Heap h1) (Heap h2) = Heap $! (mergeNodes h1 h2)
+
+mergeNodes :: (Ord a, Eq a) => [HeapNode a (BinomialHeap a)] -> [HeapNode a (BinomialHeap a)] -> [HeapNode a (BinomialHeap a)]
+mergeNodes [] h = h
+mergeNodes h [] = h
+mergeNodes f@(h1:t1) s@(h2:t2) =
+ if rank h1 == rank h2
+ then let merged = (combine h1 h2)
+ r = rank merged in
+ if r /= hRank t1
+ then if r /= hRank t2
+ then merged:(mergeNodes t1 t2)
+ else mergeNodes (merged:t1) t2
+ else if r /= hRank t2
+ then mergeNodes t1 (merged:t2)
+ else merged:(mergeNodes t1 t2)
+ else if rank h1 < rank h2
+ then h1:(mergeNodes t1 s)
+ else h2:(mergeNodes t2 f)
+
+combine :: (Ord a, Eq a) => HeapNode a (BinomialHeap a) -> HeapNode a (BinomialHeap a) -> HeapNode a (BinomialHeap a)
+combine h1@(HeapNode e1 n1 l1) h2 =
+ if h1 <= h2
+ then HeapNode e1 (n1 + 1) (l1 ++ [Heap [h2]])
+ else combine h2 h1
+
+-- | /O(lg n)/
+head :: (Ord a) => BinomialHeap a -> a
+head EmptyHeap = error "Data.Heap: empty list"
+head (Heap hn) = extract $! minimum hn
+
+-- | /O(lg n)/
+tail :: (Ord a) => BinomialHeap a -> BinomialHeap a
+tail EmptyHeap = error "Data.Heap: empty list"
+tail (Heap hn) =
+ let n@(HeapNode _ _ hd) = (minimum hn) in
+ foldl merge (Heap (delete n hn)) hd
+
+-- | /O(n)/
+fromList :: (Ord a, Eq a) => [a] -> BinomialHeap a
+fromList [] = EmptyHeap
+fromList l = (\ ((hd:_):_) -> hd) $ dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $! map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a]
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a
+
+-- | /O(n lg n)/
+toList :: (Ord a) => BinomialHeap a -> [a]
+toList EmptyHeap = []
+toList (Heap []) = []
+toList h@(Heap _) = (head h):(toList $ if null h then h else tail h)
diff --git a/Data/Heap/Skew.hs b/Data/Heap/Skew.hs
new file mode 100644
index 0000000..b97f55f
--- /dev/null
+++ b/Data/Heap/Skew.hs
@@ -0,0 +1,63 @@
+--
+-- Copyright (c) 2009 Brendan Hickey - http://bhickey.net
+-- Simplified BSD License (see http://www.opensource.org/licenses/bsd-license.php)
+--
+
+module Data.Heap.Skew
+(SkewHeap, head, tail, merge, singleton, empty, null, fromList, toList, insert)
+where
+
+import Prelude hiding (head, tail, null)
+import qualified Data.List as L
+
+data (Ord a) => SkewHeap a =
+ SkewLeaf
+ | SkewHeap a (SkewHeap a) (SkewHeap a) deriving (Eq, Ord)
+
+empty :: (Ord a) => SkewHeap a
+empty = SkewLeaf
+
+null :: (Ord a) => SkewHeap a -> Bool
+null SkewLeaf = True
+null _ = False
+
+singleton :: (Ord a) => a -> SkewHeap a
+singleton n = SkewHeap n SkewLeaf SkewLeaf
+
+insert :: (Ord a) => SkewHeap a -> a -> SkewHeap a
+insert h a = merge h (singleton a)
+
+merge :: (Ord a) => SkewHeap a -> SkewHeap a -> SkewHeap a
+merge SkewLeaf n = n
+merge n SkewLeaf = n
+merge h1 h2 = foldl1 assemble $ L.sortBy (\ x y -> compare y x) $ (cutRight h1) ++ (cutRight h2)
+
+cutRight :: (Ord a) => SkewHeap a -> [SkewHeap a]
+cutRight SkewLeaf = []
+cutRight (SkewHeap a l r) = (SkewHeap a l SkewLeaf):(cutRight r)
+
+-- assumes h1 >= h2, merge relies on this
+assemble :: (Ord a) => SkewHeap a -> SkewHeap a -> SkewHeap a
+assemble h1 (SkewHeap a l SkewLeaf) = SkewHeap a h1 l
+assemble _ _ = error "invalid heap assembly"
+
+head :: (Ord a) => SkewHeap a -> a
+head SkewLeaf = error "head of empty heap"
+head (SkewHeap a _ _) = a
+
+tail :: (Ord a) => SkewHeap a -> SkewHeap a
+tail SkewLeaf = error "tail of empty heap"
+tail (SkewHeap _ l r) = merge l r
+
+toList :: (Ord a) => SkewHeap a -> [a]
+toList SkewLeaf = []
+toList (SkewHeap n l r) = n:(toList $ merge l r)
+
+fromList :: (Ord a) => [a] -> SkewHeap a
+fromList [] = SkewLeaf
+fromList l = (\ ((hd:_):_) -> hd) $! dropWhile (\ x -> length x > 1) $ iterate (pairWise merge) $ map singleton l
+
+pairWise :: (a -> a -> a) -> [a] -> [a]
+pairWise _ [] = []
+pairWise f (a:b:tl) = (f a b):(pairWise f tl)
+pairWise _ a = a