LeftistHeap.hs (2428B)
1 {-# OPTIONS_GHC -Wall #-} 2 3 module LeftistHeap where 4 5 import Control.Arrow 6 7 data Heap a = Leaf | Node Int a (Heap a) (Heap a) deriving (Eq, Show) 8 9 empty :: Heap a 10 empty = Leaf 11 12 isEmpty :: Heap a -> Bool 13 isEmpty Leaf = True 14 isEmpty _ = False 15 16 merge :: Ord a => Heap a -> Heap a -> Heap a 17 merge h Leaf = h 18 merge Leaf h = h 19 merge h0@(Node _ e0 l0 r0) h1@(Node _ e1 l1 r1) 20 | e0 <= e1 = create e0 l0 (merge r0 h1) 21 | otherwise = create e1 l1 (merge h0 r1) 22 23 rank :: Heap a -> Int 24 rank Leaf = 0 25 rank (Node r _ _ _) = r 26 27 create :: a -> Heap a -> Heap a -> Heap a 28 create e l r 29 | rank l >= rank r = Node (succ (rank r)) e l r 30 | otherwise = Node (succ (rank l)) e r l 31 32 singleton :: Ord a => a -> Heap a 33 singleton e = Node 1 e Leaf Leaf 34 35 insert :: Ord a => a -> Heap a -> Heap a 36 insert e = merge (singleton e) 37 38 findMin :: Heap a -> Maybe a 39 findMin Leaf = Nothing 40 findMin (Node _ e _ _) = return e 41 42 deleteMin :: Ord a => Heap a -> Heap a 43 deleteMin Leaf = Leaf 44 deleteMin (Node _ _ l r) = merge l r 45 46 fromList :: Ord a => [a] -> Heap a 47 fromList = foldr insert empty 48 49 -- exercise 3.1 (prove right-spine contains at most floor(log(n + 1)) elements) 50 -- - binary tree; observe that rightmost-weighted binary tree obeying leftist 51 -- property is balanced. 52 -- - right spine length is maximized in balanced case. 53 -- - tree has depth floor(log(n + 1)) in balanced case. 54 -- - right spine has at most floor(log(n + 1)) elements. 55 56 -- exercise 3.2 (define insert directly rather than by merge) 57 altInsert :: Ord a => a -> Heap a -> Heap a 58 altInsert e Leaf = singleton e 59 altInsert e0 (Node _ e1 l r) = create upper l0 r0 where 60 (l0, r0) = cascadeInsert (l, r) 61 (upper, lower) 62 | e0 <= e1 = (e0, e1) 63 | otherwise = (e1, e0) 64 65 cascadeInsert (h, Leaf) = (h, singleton lower) 66 cascadeInsert (Leaf, h) = (h, singleton lower) 67 cascadeInsert hs@(Node _ x _ _, Node _ y _ _) 68 | x > y = first (altInsert lower) hs 69 | otherwise = second (altInsert lower) hs 70 71 -- exercise 3.3 (implement alternate fromList) 72 -- - foldup halves list length on each pass, log n foldups 73 altFromList :: Ord a => [a] -> Heap a 74 altFromList [] = Leaf 75 altFromList es 76 | even (length xs) = merge x (wrapup xs) 77 | otherwise = wrapup (x:xs) 78 where 79 (x:xs) = fmap singleton es 80 81 foldup [] = [] 82 foldup (_:[]) = [] 83 foldup (z0:z1:zs) = merge z0 z1 : foldup zs 84 85 wrapup [z] = z 86 wrapup zs = wrapup (foldup zs) 87