UnrankedBinomialHeap.hs (1756B)
1 {-# OPTIONS_GHC -Wall #-} 2 3 module UnrankedBinomialHeap where 4 5 -- exercise 3.6 (alternate-rank representation of binomial heaps) 6 data Tree a = Node a [Tree a] deriving Show 7 8 type Heap a = [(Int, Tree a)] 9 10 empty :: Heap a 11 empty = [] 12 13 isEmpty :: Heap a -> Bool 14 isEmpty = null 15 16 link :: Ord a => (Int, Tree a) -> (Int, Tree a) -> (Int, Tree a) 17 link (r, t0@(Node x0 c0)) (_, t1@(Node x1 c1)) 18 | x0 <= x1 = (succ r, Node x0 (t1 : c0)) 19 | otherwise = (succ r, Node x1 (t0 : c1)) 20 21 root :: Tree a -> a 22 root (Node x _) = x 23 24 insertTree :: Ord a => (Int, Tree a) -> Heap a -> Heap a 25 insertTree p [] = [p] 26 insertTree p0@(r0, _) ts@(p1@(r1, _):trees) 27 | r0 < r1 = p0 : ts 28 | otherwise = insertTree (link p0 p1) trees 29 30 insert :: Ord a => a -> Heap a -> Heap a 31 insert x = insertTree (0, Node x []) 32 33 merge :: Ord a => Heap a -> Heap a -> Heap a 34 merge ts [] = ts 35 merge [] ts = ts 36 merge ts0@(tree0:trees0) ts1@(tree1:trees1) 37 | fst tree0 < fst tree1 = tree0 : merge trees0 ts1 38 | fst tree1 < fst tree0 = tree1 : merge ts0 trees1 39 | otherwise = insertTree (link tree0 tree1) (merge trees0 trees1) 40 41 removeMinTree :: Ord a => Heap a -> Maybe ((Int, Tree a), Heap a) 42 removeMinTree [] = Nothing 43 removeMinTree [p] = return (p, []) 44 removeMinTree (p0@(_, t):ts) = do 45 (p1@(_, tree), trees) <- removeMinTree ts 46 return $ 47 if root t < root tree 48 then (p0, ts) 49 else (p1, p0:trees) 50 51 findMin :: Ord a => Heap a -> Maybe a 52 findMin ts = do 53 ((_, t), _) <- removeMinTree ts 54 return $ root t 55 56 deleteMin :: Ord a => Heap a -> Heap a 57 deleteMin ts = case removeMinTree ts of 58 Nothing -> [] 59 Just ((r, Node _ ts0), ts1) -> 60 let lesser = zip (repeat (pred r)) (reverse ts0) 61 in merge lesser ts1 62 63 fromList :: Ord a => [a] -> Heap a 64 fromList = foldr insert empty 65