okasaki

Okasaki's Purely Functional Data Structures
git clone git://git.jtobin.io/okasaki.git
Log | Files | Refs | LICENSE

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