okasaki

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

BinomialHeap.hs (3152B)

      1 {-# OPTIONS_GHC -Wall #-}
      2 
      3 module BinomialHeap where
      4 
      5 data Tree a = Node Int a [Tree a] deriving Show
      6 
      7 type Heap a = [Tree a]
      8 
      9 empty :: Heap a
     10 empty = []
     11 
     12 isEmpty :: Heap a -> Bool
     13 isEmpty = null
     14 
     15 link :: Ord a => Tree a -> Tree a -> Tree a
     16 link t0@(Node r x0 c0) t1@(Node _ x1 c1)
     17   | x0 <= x1  = Node (succ r) x0 (t1 : c0)
     18   | otherwise = Node (succ r) x1 (t0 : c1)
     19 
     20 rank :: Tree a -> Int
     21 rank (Node r _ _) = r
     22 
     23 root :: Tree a -> a
     24 root (Node _ x _) = x
     25 
     26 insertTree :: Ord a => Tree a -> Heap a -> Heap a
     27 insertTree t [] = [t]
     28 insertTree t ts@(tree:trees)
     29   | rank t < rank tree = t : ts
     30   | otherwise          = insertTree (link t tree) trees
     31 
     32 insert :: Ord a => a -> Heap a -> Heap a
     33 insert x = insertTree (Node 0 x [])
     34 
     35 merge :: Ord a => Heap a -> Heap a -> Heap a
     36 merge ts [] = ts
     37 merge [] ts = ts
     38 merge ts0@(tree0:trees0) ts1@(tree1:trees1)
     39   | rank tree0 < rank tree1 = tree0 : merge trees0 ts1
     40   | rank tree1 < rank tree0 = tree1 : merge ts0 trees1
     41   | otherwise = insertTree (link tree0 tree1) (merge trees0 trees1)
     42 
     43 removeMinTree :: Ord a => Heap a -> Maybe (Tree a, Heap a)
     44 removeMinTree []     = Nothing
     45 removeMinTree [t]    = return (t, [])
     46 removeMinTree (t:ts) = do
     47   (tree, trees) <- removeMinTree ts
     48   return $
     49     if   root t < root tree
     50     then (t, ts)
     51     else (tree, t:trees)
     52 
     53 findMin :: Ord a => Heap a -> Maybe a
     54 findMin ts = do
     55   (t, _) <- removeMinTree ts
     56   return $ root t
     57 
     58 deleteMin :: Ord a => Heap a -> Heap a
     59 deleteMin ts = case removeMinTree ts of
     60   Nothing                  -> []
     61   Just (Node _ _ ts0, ts1) -> merge (reverse ts0) ts1
     62 
     63 fromList :: Ord a => [a] -> Heap a
     64 fromList = foldr insert empty
     65 
     66 -- exercise 3.5 (findMin without call to removeMinTree)
     67 altFindMin :: Ord a => Heap a -> Maybe a
     68 altFindMin []     = Nothing
     69 altFindMin [t]    = return $ root t
     70 altFindMin (Node _ e _:ts) = do
     71   alt <- altFindMin ts
     72   return $
     73     if   e < alt
     74     then e
     75     else alt
     76 
     77 -- exercise 3.7 (O(1) min in ocaml functor style)
     78 class Heaplike h where
     79   hEmpty     :: h a
     80   hIsEmpty   :: h a -> Bool
     81   hInsert    :: Ord a => a -> h a -> h a
     82   hFindMin   :: Ord a => h a -> Maybe a
     83   hDeleteMin :: Ord a => h a -> h a
     84 
     85   hFromList :: Ord a => [a] -> h a
     86   hFromList = foldr hInsert hEmpty
     87 
     88 data ExplicitMinHeap h a = E | NE a (h a) deriving Show
     89 
     90 instance Heaplike h => Heaplike (ExplicitMinHeap h) where
     91   hEmpty = E
     92 
     93   hIsEmpty E = True
     94   hIsEmpty _ = False
     95 
     96   hInsert e E = NE e (hInsert e hEmpty)
     97   hInsert e (NE m h) = NE (min e m) (hInsert e h)
     98 
     99   hFindMin E = Nothing
    100   hFindMin (NE m _) = Just m
    101 
    102   hDeleteMin E = hEmpty
    103   hDeleteMin (NE m0 h) =
    104     let smaller = hDeleteMin h
    105     in  case hFindMin smaller of
    106           Nothing -> NE m0 smaller
    107           Just m1 -> NE (min m0 m1) smaller
    108 
    109 -- example
    110 newtype BinomialHeap a = BinomialHeap { unwrap :: Heap a } deriving Show
    111 
    112 instance Heaplike BinomialHeap where
    113   hEmpty   = BinomialHeap empty
    114   hIsEmpty = isEmpty . unwrap
    115   hInsert e (BinomialHeap h)  = BinomialHeap $ insert e h
    116   hFindMin (BinomialHeap h)   = findMin h
    117   hDeleteMin (BinomialHeap h) = BinomialHeap $ deleteMin h
    118 
    119 altFromList :: Ord a => [a] -> ExplicitMinHeap BinomialHeap a
    120 altFromList = hFromList
    121