Robust/src/Benchmarks/Scheduling/GC/NON_BAMBOO/Fibheaps/fibheaps.hs

   1 {-
   2 Date:    Tue, 04 Jul 1995 13:10:58 -0400
   3 From:    Chris_Okasaki@LOCH.MESS.CS.CMU.EDU
   4 To:      simonpj@dcs.gla.ac.uk
   5 Subject: Fibonacci Heaps
   6
   7 As I promised at the Haskell Workshop, here is a sample program
   8 using encapsulated state.  I've translated this from SML, but
   9 in doing so, I noticed that in fact accumArray is all the
  10 encapsulated state you really need for this application.  In SML,
  11 we are forced to use mutable arrays because we don't have such
  12 fancy monolithic array "primitives" as accumArray.
  13
  14 I've written and tested this as a literate Gofer script because I've
  15 never been able to get GHC to run under Mach. :-(
  16
  17 Let me know if you have any problems...
  18
  19 Chris
  20
  21
  22 - ----------------------------------------------------------------------
  23
  24 FIBONACCI HEAPS
  25
  26 Fibonacci heaps are a priority queue data structure supporting the
  27 following operations:
  28         O(1) Insert
  29         O(1) FindMin
  30         O(1) Meld
  31     O(log n) DeleteMin
  32
  33 (In an imperative settting, Fibonacci heaps also support
  34         O(1) DecreaseKey (of an indicated element)
  35     O(log n) Delete (an indicated element)
  36 but these operations are problematic in a functional setting.)
  37
  38 There is one catch: for the DeleteMin operation, the bounds are
  39 amortized instead of worst-case.  This means that the bounds are
  40 only guaranteed if you use the data structure in a single-threaded manner.
  41 Otherwise, you can take longer than expected by repeatedly going back
  42 and operating on an "expensive" version of the data structure.
  43
  44 (Note: I am currently working on a paper with another student describing
  45 a functional priority queue achieving the above bounds in the worst-case
  46 instead of amortized.  This data structure may be freely used in a
  47 non-single-threaded manner with no ill effects.)
  48
  49 To understand the implementation of Fibonacci heaps, it is helpful to
  50 first understand binomial queues.  See, for example, David King's
  51 "Functional Binomial Queues" from the last Glasgow workshop.
  52 -}
  53
  54 import Data.Array
  55 import System.IO
  56 import System
  57
  58 import Control.Monad.ST
  59 import Data.Array.ST
  60
  61
  62 {-
  63 Like binomial queues, Fibonacci heaps are based on heap-ordered
  64 binomial trees.
  65 -}
  66
  67 data Tree a = Node !a [Tree a]
  68
  69 {-
  70 The degree of a binomial tree is equal to its number of children.
  71 Every binomial tree of degree k has binomial trees of degrees
  72 k-1...0 as children, in that order.  It is easy to show that
  73 a binomial tree of degree k has size 2^k.
  74
  75
  76 The fundamental operation on binomial trees is linking, which compares
  77 the roots of two binomial trees and makes the larger a child of the
  78 smaller (thus bumping its degree by one).  It is essential that this
  79 only be called on binomial trees of equal degree.
  80 -}
  81
  82 link (a @ (Node x as)) (b @ (Node y bs)) =
  83   if x <= y then Node x (b:as) else Node y (a:bs)
  84
  85 -- It will also be useful to extract the minimum element from a tree.
  86
  87 root (Node x _) = x
  88
  89 -- We will frequently need to tag trees with their degrees.
  90
  91 type TaggedTree a = (Int,Tree a)
  92
  93 degree (k, t) = k
  94 tree (k, t) = t
  95
  96 -- Given a tagged tree, extract and tag its children.
  97
  98 getChildren (n, Node x ts) = zipWith (,) [n-1,n-2 .. ] ts
  99
 100 -- Extract the minimum element from a tagged tree.
 101
 102 root' = root . tree
 103
 104 {-
 105                          --------------------
 106
 107 We also need a type for bags supporting constant time union.  The simple
 108 representation given here is sufficient since we will always process bags
 109 as a whole.  Note that for this application it is not necessary to
 110 filter out occurences of EmptyBag.  Also, for this application order
 111 is irrelevant.
 112 -}
 113
 114 data Bag a = EmptyBag | ConsBag a (Bag a) | UnionBags (Bag a) (Bag a)
 115
 116 bagToList b = flatten b []
 117   where flatten EmptyBag xs = xs
 118         flatten (ConsBag x b) xs = flatten b (x:xs)
 119         flatten (UnionBags b1 b2) xs = flatten b1 (flatten b2 xs)
 120
 121 applyToAll :: (a -> ST s ()) -> Bag a -> ST s ()
 122 applyToAll f EmptyBag = return ()
 123 applyToAll f (ConsBag x b) = f x >> applyToAll f b
 124 applyToAll f (UnionBags b1 b2) = applyToAll f b1 >> applyToAll f b2
 125
 126
 127 -- Miscellaneous stuff.
 128
 129 log2 1 = 0
 130 log2 n = 1 + log2 (n `div` 2)
 131
 132 data MyMaybe a = Zero | One !a
 133
 134 {-
 135                          --------------------
 136
 137 Since binomial trees only come in certain, fixed sizes, we need some
 138 way to represent priority queues of other sizes.  We will do this
 139 with a forest of trees summing to the correct size.
 140 -}
 141
 142 type Forest a = Bag (TaggedTree a)
 143
 144 {-
 145 In binomial queues, this forest must be maintained in strictly increasing
 146 order of degree.  For Fibonacci heaps, we adopt a more relaxed attitude:
 147 degrees may be repeated and order does not matter.
 148
 149 To be able to find the minimum element quickly, we keep the tree with the
 150 minimum root outside of the bag.  In addition, at the top level of each heap,
 151 we store the total size of the heap.
 152 -}
 153
 154 data FibHeap a = EmptyFH | FH !Int (TaggedTree a) (Forest a)
 155
 156
 157 -- Now, the following operations are trivial.
 158
 159 emptyFH = EmptyFH
 160
 161 isEmptyFH EmptyFH = True
 162 isEmptyFH (FH _ _ _) = False
 163
 164 singleFH x = FH 1 (0, Node x []) EmptyBag
 165
 166 insertFH x xs = meldFH (singleFH x) xs
 167
 168 minFH EmptyFH = error "minFH EmptyFH"
 169 minFH (FH n tt f) = root' tt
 170
 171
 172 {-
 173                          --------------------
 174
 175 Meld achieves its efficiency by simply unioning the two forests.
 176 -}
 177
 178 meldFH EmptyFH xs = xs
 179 meldFH xs EmptyFH = xs
 180 meldFH (FH n1 tt1 f1) (FH n2 tt2 f2) =
 181   if root' tt1 <= root' tt2 then
 182       FH (n1+n2) tt1 (ConsBag tt2 (UnionBags f1 f2))
 183   else
 184       FH (n1+n2) tt2 (ConsBag tt1 (UnionBags f1 f2))
 185
 186 {-
 187 Finally, the only hard operation is deleteMin.  After throwing away the
 188 minimum element, it repeatedly links trees of equal degree until
 189 no such pairs are left.  The most efficient way to do this is with
 190 an array.  I give two implementations, one using monadic arrays,
 191 the other using accumArray.
 192
 193 In the first implementation, there are three steps.
 194   1. Allocate an array indexed by degrees.
 195   2. Insert every tree into this array.  If, when inserting a tree of
 196      degree k, there already exists a tree of degree k, link the
 197      two trees and reinsert the new larger tree.
 198   3. Transfer the trees into a bag, keeping track of the minimum tree.
 199 -}
 200
 201 deleteMinFH EmptyFH = error "deleteMinFH EmptyFH"
 202 deleteMinFH (FH 1 tt f) = EmptyFH
 203 deleteMinFH (FH n tt f) =
 204   let
 205     d = log2 (n-1) -- maximum possible degree
 206
 207     ins :: Ord a => STArray s Int (MyMaybe (Tree a)) -> (Int,Tree a) -> ST s ()
 208     ins a (i, t) =
 209         readArray a i >>= \e ->
 210         case e of
 211           Zero   -> writeArray a i (One t)
 212           One t2 -> writeArray a i Zero >>
 213                     ins a (i+1, link t t2)
 214
 215 {-
 216 Note that after inserting all the trees, the array contains trees
 217 in the same pattern as the bits of n-1.  Since we know that the
 218 highest order bit of n-1 is one, we know that there is a tree in
 219 the highest slot of the array.
 220 -}
 221
 222     getMin a =
 223         readArray a d >>= \e ->
 224         case e of
 225           Zero  -> error "must be One" -- since array is filled as bits of n-1
 226           One t -> getMin' a d t EmptyBag 0
 227     getMin' a mini mint b i =
 228         if i >= d then
 229           return ((mini, mint),b)
 230         else
 231           readArray a i >>= \e ->
 232           case e of
 233             Zero  -> getMin' a mini mint b (i+1)
 234             One t -> if root mint <= root t then
 235                        getMin' a mini mint (ConsBag (i, t) b) (i+1)
 236                      else
 237                        getMin' a i t (ConsBag (mini, mint) b) (i+1)
 238
 239   in
 240     runST (newArray (0,d) Zero >>= \a ->
 241            applyToAll (ins a) f >>
 242            sequence (map (ins a) (getChildren tt)) >>
 243            getMin a >>= \ (tt,f) ->
 244            return (FH (n-1) tt f))
 245
 246 {-
 247 The second version of deleteMin uses accumArray to group trees of like
 248 size.  It then performs the linking and all remaining steps purely
 249 functionally.
 250 -}
 251
 252 deleteMinFH' EmptyFH = error "deleteMinFH EmptyFH"
 253 deleteMinFH' (FH 1 tt f) = EmptyFH
 254 deleteMinFH' (FH n tt f) =
 255   let
 256     d = log2 (n-1) -- maximum possible degree
 257
 258     a = accumArray (flip (:)) [] (0,d) (getChildren tt ++ bagToList f)
 259
 260     doLinks (ts:rest) = startup 0 ts rest
 261       where startup i [] [] = []
 262             startup i [] (ts:rest) = startup (i+1) ts rest
 263             startup i ts [] = combine i ts [] []
 264             startup i ts (next:rest) = combine i ts next rest
 265
 266             combine i [] next rest = startup (i+1) next rest
 267             combine i [t] next rest = (i, t) : startup (i+1) next rest
 268             combine i (t1:t2:ts) next rest =
 269                 combine i ts (link t1 t2 : next) rest
 270
 271     getMin (tt:rest) = foldl chooseMin (tt,EmptyBag) rest
 272       where chooseMin (tt1,b) tt2 =
 273                 if root' tt1 <= root' tt2 then
 274                     (tt1,ConsBag tt2 b)
 275                 else
 276                     (tt2,ConsBag tt1 b)
 277
 278     (new_tt,new_f) = getMin (doLinks (elems a))
 279   in
 280     FH (n-1) new_tt new_f
 281
 282
 283 -- Testing...
 284
 285 fibToList :: (Ord a) => FibHeap a -> [a]
 286 fibToList xs = if isEmptyFH xs then []
 287                else minFH xs : fibToList (deleteMinFH xs)
 288
 289 fibToList' :: (Ord a) => FibHeap a -> [a]
 290 fibToList' xs = if isEmptyFH xs then []
 291                 else minFH xs : fibToList' (deleteMinFH' xs)
 292
 293 makeFH :: (Ord a) => [a] -> FibHeap a
 294 makeFH xs = foldr insertFH emptyFH xs
 295
 296 fibSort :: (Ord a) => [a] -> [a]
 297 fibSort = fibToList . makeFH
 298
 299 fibSort' :: (Ord a) => [a] -> [a]
 300 fibSort' = fibToList' . makeFH
 301
 302 randoms :: Int -> [Int]
 303 randoms n = take n (iterate (\seed-> (77*seed+1) `rem` 1024) 1967)
 304
 305 test n = fibSort (randoms n) == fibSort' (randoms n)
 306
 307 --partain
 308 main = getArgs >>= \ [n] -> putStrLn (show (test (read n)))