commit b39631fa0a5252fe6659125116260ef7790456f0
parent 3e3ee09745af8c15873103c399f2cc9a9c402763
Author: Jared Tobin <jared@jtobin.ca>
Date: Thu, 20 Nov 2014 23:31:16 +1300
Some work on leftist heaps.
Diffstat:
| A | FiniteMap.hs | | | 39 | +++++++++++++++++++++++++++++++++++++++ |
| A | LeftistHeap.hs | | | 73 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | Tree.hs | | | 33 | --------------------------------- |
3 files changed, 112 insertions(+), 33 deletions(-)
diff --git a/FiniteMap.hs b/FiniteMap.hs
@@ -0,0 +1,39 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module FiniteMap where
+
+import Tree
+
+-- exercise 2.6 (finite map using tree)
+newtype Bin k v = Bin (k, v) deriving Show
+
+instance Eq k => Eq (Bin k v) where
+ Bin (k0, _) == Bin (k1, _) = k0 == k1
+
+instance Ord k => Ord (Bin k v) where
+ compare (Bin (k0, _)) (Bin (k1, _)) = compare k0 k1
+
+newtype FiniteMap k v = FiniteMap (Tree (Bin k v)) deriving (Eq, Show)
+
+emptyMap :: FiniteMap k v
+emptyMap = FiniteMap Leaf
+
+bind :: Ord k => k -> v -> FiniteMap k v -> FiniteMap k v
+bind k v (FiniteMap m) = FiniteMap (insert' (Bin (k, v)) m) where
+ insert' x Leaf = Node Leaf x Leaf
+ insert' x (Node l e r) = case compare x e of
+ EQ -> Node l x r
+ LT -> Node (insert' x l) e r
+ GT -> Node l e (insert' x r)
+
+lookup :: Ord k => k -> FiniteMap k v -> Maybe v
+lookup k (FiniteMap m) = lookup' m where
+ lookup' Leaf = Nothing
+ lookup' (Node l (Bin (key, v)) r) = case compare k key of
+ EQ -> Just v
+ LT -> lookup' l
+ GT -> lookup' r
+
+testMap :: FiniteMap Char Int
+testMap = bind 'b' 2 (bind 'a' 1 emptyMap)
+
diff --git a/LeftistHeap.hs b/LeftistHeap.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module LeftistHeap where
+
+import Control.Arrow
+
+data Heap a = Leaf | Node Int a (Heap a) (Heap a) deriving (Eq, Show)
+
+empty :: Heap a
+empty = Leaf
+
+isEmpty :: Heap a -> Bool
+isEmpty Leaf = True
+isEmpty _ = False
+
+merge :: Ord a => Heap a -> Heap a -> Heap a
+merge h Leaf = h
+merge Leaf h = h
+merge h0@(Node _ e0 l0 r0) h1@(Node _ e1 l1 r1)
+ | e0 <= e1 = create e0 l0 (merge r0 h1)
+ | otherwise = create e1 l1 (merge h0 r1)
+
+rank :: Heap a -> Int
+rank Leaf = 0
+rank (Node r _ _ _) = r
+
+create :: a -> Heap a -> Heap a -> Heap a
+create e l r
+ | rank l >= rank r = Node (succ (rank r)) e l r
+ | otherwise = Node (succ (rank l)) e r l
+
+singleton :: Ord a => a -> Heap a
+singleton e = Node 1 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
+
+-- exercise 3.1 (prove right-spine contains at most floor(log(n + 1)) elements)
+-- - binary tree; observe that rightmost-weighted binary tree obeying leftist
+-- property is balanced.
+-- - right spine length is maximized in balanced case.
+-- - tree has depth floor(log(n + 1)) in balanced case.
+-- - right spine has at most floor(log(n + 1)) elements.
+
+-- exercise 3.2 (define insert directly rather than by merge)
+altInsert :: Ord a => a -> Heap a -> Heap a
+altInsert e Leaf = singleton e
+altInsert e0 (Node _ e1 l r)
+ | rank l0 >= rank r0 = Node (succ (rank r0)) top l0 r0
+ | otherwise = Node (succ (rank l0)) top r0 l0
+ where
+ (l0, r0) = cascadeInsert bottom (l, r)
+ (top, bottom)
+ | e0 <= e1 = (e0, e1)
+ | otherwise = (e1, e0)
+
+cascadeInsert :: Ord a => a -> (Heap a, Heap a) -> (Heap a, Heap a)
+cascadeInsert e (h, Leaf) = (h, singleton e)
+cascadeInsert e (Leaf, h) = (h, singleton e)
+cascadeInsert e hs@(Node _ e0 _ _, Node _ e1 _ _) = f (altInsert e) hs where
+ f = if e0 > e1 then first else second
+
diff --git a/Tree.hs b/Tree.hs
@@ -79,36 +79,3 @@ completeSize x n
r = completeSize x (n `quot` 2 - 1)
in Node l x r
--- exercise 2.6 (finite map using tree)
-newtype Bin k v = Bin (k, v) deriving Show
-
-instance Eq k => Eq (Bin k v) where
- Bin (k0, _) == Bin (k1, _) = k0 == k1
-
-instance Ord k => Ord (Bin k v) where
- compare (Bin (k0, _)) (Bin (k1, _)) = compare k0 k1
-
-newtype FiniteMap k v = FiniteMap (Tree (Bin k v)) deriving (Eq, Show)
-
-emptyMap :: FiniteMap k v
-emptyMap = FiniteMap Leaf
-
-bind :: Ord k => k -> v -> FiniteMap k v -> FiniteMap k v
-bind k v (FiniteMap m) = FiniteMap (insert' (Bin (k, v)) m) where
- insert' x Leaf = Node Leaf x Leaf
- insert' x (Node l e r) = case compare x e of
- EQ -> Node l x r
- LT -> Node (insert' x l) e r
- GT -> Node l e (insert' x r)
-
-lookup :: Ord k => k -> FiniteMap k v -> Maybe v
-lookup k (FiniteMap m) = lookup' m where
- lookup' Leaf = Nothing
- lookup' (Node l (Bin (key, v)) r) = case compare k key of
- EQ -> Just v
- LT -> lookup' l
- GT -> lookup' r
-
-testMap :: FiniteMap Char Int
-testMap = bind 'b' 2 (bind 'a' 1 emptyMap)
-
