commit a1e4d2e8a9d3b7476aad8ab80152cae96624ecf8
parent 2cf32a073a1b260c7c9f29b245b06339296c68b7
Author: Jared Tobin <jared@jtobin.ca>
Date: Sat, 22 Nov 2014 21:42:21 +1300
Moar heap work.
Diffstat:
3 files changed, 141 insertions(+), 3 deletions(-)
diff --git a/BinomialHeap.hs b/BinomialHeap.hs
@@ -2,10 +2,16 @@
module BinomialHeap where
-data Tree a = Node Int a [Tree a]
+data Tree a = Node Int a [Tree a] deriving Show
type Heap a = [Tree a]
+empty :: Heap a
+empty = []
+
+isEmpty :: Heap a -> Bool
+isEmpty = null
+
link :: Ord a => Tree a -> Tree a -> Tree a
link t0@(Node r x0 c0) t1@(Node _ x1 c1)
| x0 <= x1 = Node (succ r) x0 (t1 : c0)
@@ -54,3 +60,62 @@ deleteMin ts = case removeMinTree ts of
Nothing -> []
Just (Node _ _ ts0, ts1) -> merge (reverse ts0) ts1
+fromList :: Ord a => [a] -> Heap a
+fromList = foldr insert empty
+
+-- exercise 3.5 (findMin without call to removeMinTree)
+altFindMin :: Ord a => Heap a -> Maybe a
+altFindMin [] = Nothing
+altFindMin [t] = return $ root t
+altFindMin (Node _ e _:ts) = do
+ alt <- altFindMin ts
+ return $
+ if e < alt
+ then e
+ else alt
+
+-- exercise 3.7 (O(1) min in ocaml functor style)
+class Heaplike h where
+ hEmpty :: h a
+ hIsEmpty :: h a -> Bool
+ hInsert :: Ord a => a -> h a -> h a
+ hFindMin :: Ord a => h a -> Maybe a
+ hDeleteMin :: Ord a => h a -> h a
+
+ hFromList :: Ord a => [a] -> h a
+ hFromList = foldr hInsert hEmpty
+
+data ExplicitMinHeap h a = E | NE a (h a) deriving Show
+
+instance Heaplike h => Heaplike (ExplicitMinHeap h) where
+ hEmpty = E
+
+ hIsEmpty E = True
+ hIsEmpty _ = False
+
+ hInsert e E = NE e (hInsert e hEmpty)
+ hInsert e (NE m h) = NE (min e m) (hInsert e h)
+
+ hFindMin E = Nothing
+ hFindMin (NE m _) = Just m
+
+ hDeleteMin E = hEmpty
+ hDeleteMin (NE m0 h) =
+ let smaller = hDeleteMin h
+ in case hFindMin smaller of
+ Nothing -> NE m0 smaller
+ Just m1 -> NE (min m0 m1) smaller
+
+-- example
+newtype BinomialHeap a = BinomialHeap { unwrap :: Heap a } deriving Show
+
+instance Heaplike BinomialHeap where
+ hEmpty = BinomialHeap empty
+ hIsEmpty = isEmpty . unwrap
+ hInsert e (BinomialHeap h) = BinomialHeap $ insert e h
+ hFindMin (BinomialHeap h) = findMin h
+ hDeleteMin (BinomialHeap h) = BinomialHeap $ deleteMin h
+
+altFromList :: Ord a => [a] -> ExplicitMinHeap BinomialHeap a
+altFromList = hFromList
+
diff --git a/UnrankedBinomialHeap.hs b/UnrankedBinomialHeap.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module UnrankedBinomialHeap where
+
+-- exercise 3.6 (alternate-rank representation of binomial heaps)
+data Tree a = Node a [Tree a] deriving Show
+
+type Heap a = [(Int, Tree a)]
+
+empty :: Heap a
+empty = []
+
+isEmpty :: Heap a -> Bool
+isEmpty = null
+
+link :: Ord a => (Int, Tree a) -> (Int, Tree a) -> (Int, Tree a)
+link (r, t0@(Node x0 c0)) (_, t1@(Node x1 c1))
+ | x0 <= x1 = (succ r, Node x0 (t1 : c0))
+ | otherwise = (succ r, Node x1 (t0 : c1))
+
+root :: Tree a -> a
+root (Node x _) = x
+
+insertTree :: Ord a => (Int, Tree a) -> Heap a -> Heap a
+insertTree p [] = [p]
+insertTree p0@(r0, _) ts@(p1@(r1, _):trees)
+ | r0 < r1 = p0 : ts
+ | otherwise = insertTree (link p0 p1) trees
+
+insert :: Ord a => a -> Heap a -> Heap a
+insert x = insertTree (0, Node x [])
+
+merge :: Ord a => Heap a -> Heap a -> Heap a
+merge ts [] = ts
+merge [] ts = ts
+merge ts0@(tree0:trees0) ts1@(tree1:trees1)
+ | fst tree0 < fst tree1 = tree0 : merge trees0 ts1
+ | fst tree1 < fst tree0 = tree1 : merge ts0 trees1
+ | otherwise = insertTree (link tree0 tree1) (merge trees0 trees1)
+
+removeMinTree :: Ord a => Heap a -> Maybe ((Int, Tree a), Heap a)
+removeMinTree [] = Nothing
+removeMinTree [p] = return (p, [])
+removeMinTree (p0@(_, t):ts) = do
+ (p1@(_, tree), trees) <- removeMinTree ts
+ return $
+ if root t < root tree
+ then (p0, ts)
+ else (p1, p0:trees)
+
+findMin :: Ord a => Heap a -> Maybe a
+findMin ts = do
+ ((_, t), _) <- removeMinTree ts
+ return $ root t
+
+deleteMin :: Ord a => Heap a -> Heap a
+deleteMin ts = case removeMinTree ts of
+ Nothing -> []
+ Just ((r, Node _ ts0), ts1) ->
+ let lesser = zip (repeat (pred r)) (reverse ts0)
+ in merge lesser ts1
+
+fromList :: Ord a => [a] -> Heap a
+fromList = foldr insert empty
+
diff --git a/WeightBiasedLeftistHeap.hs b/WeightBiasedLeftistHeap.hs
@@ -41,6 +41,14 @@ singleton e = Node e Leaf Leaf
insert :: Ord a => a -> Heap a -> Heap a
insert e = merge (singleton e)
+findMin :: Heap a -> Maybe a
+findMin Leaf = Nothing
+findMin (Node e _ _) = return e
+
+deleteMin :: Ord a => Heap a -> Heap a
+deleteMin Leaf = Leaf
+deleteMin (Node _ l r) = merge l r
+
fromList :: Ord a => [a] -> Heap a
fromList = foldr insert empty
@@ -58,6 +66,6 @@ altMerge h0@(Node e0 l0 r0) h1@(Node e1 l1 r1) = Node e l r where
| otherwise = second (`altMerge` h) branches
-- exercise 3.4d (advantages of altMerge)
--- - lazy environment ?
--- - concurrent environment ?
+-- - lazy environment (no buildup of thunks?)
+-- - concurrent environment (more opportunity for concurrency?)
