lib/mlton/heap/forest.fun

   1 (* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 (* Forest of heap ordered trees.
   9  * Can be specialized to eager or lazy binomial heaps, fibonacci heaps.
  10  *)
  11
  12 functor ForestHeap (S: FOREST_HEAP_STRUCTS): FOREST_HEAP =
  13 struct
  14
  15 open S
  16
  17 structure Elt =
  18 struct
  19    (* Can't make child a circular list, because the elements aren't defined yet.
  20     *)
  21    datatype 'a t = T of {value: 'a Pointer.t,
  22                          mark: bool ref,
  23                          parent: 'a t Pointer.t,
  24                          next: 'a t Pointer.t,
  25                          prev: 'a t Pointer.t,
  26                          child: 'a t Pointer.t,
  27                          numChildren: int ref}
  28
  29    fun destruct(T{prev, value, next, ...}) = (prev, Pointer.! value, next)
  30
  31    fun make p = T{value = p,
  32                   mark = ref false,
  33                   parent = Pointer.null(),
  34                   next = Pointer.null(),
  35                   prev = Pointer.null(),
  36                   child = Pointer.null(),
  37                   numChildren = ref 0}
  38
  39    fun new v = make(Pointer.new v)
  40
  41    fun dummy v = make(Pointer.null())
  42
  43    fun valuePtr(T{value, ...}) = value
  44    fun value e = Pointer.!(valuePtr e)
  45    fun mark(T{mark, ...}) = mark := true
  46    fun unMark(T{mark, ...}) = mark := false
  47    fun isMarked(T{mark, ...}) = !mark
  48    fun parent(T{parent, ...}) = Pointer.! parent
  49    fun hasParent(T{parent, ...}) = not(Pointer.isNull parent)
  50    fun setParent(T{parent, ...}, p) = Pointer.:=(parent, p)
  51    fun clearParent(T{parent, ...}) = Pointer.clear parent
  52    fun next(T{next, ...}) = next
  53    fun prev(T{prev, ...}) = prev
  54    fun child(T{child, ...}) = child
  55    fun numChildrenRef(T{numChildren, ...}) = numChildren
  56    fun numChildren e = !(numChildrenRef e)
  57    fun incNumChildren e = Int.inc(numChildrenRef e)
  58    fun decNumChildren e = Int.dec(numChildrenRef e)
  59    val equals = fn (e, e') => Pointer.eq(valuePtr e, valuePtr e')
  60 end
  61
  62 structure CircList = CircularList(structure Elt = DoublyLinked(Elt))
  63
  64 structure Elt =
  65    struct
  66       open Elt
  67       type 'a t = (Key.t * 'a) Elt.t
  68
  69       fun key(e: 'a t) = #1(value e)
  70       fun value(e: 'a t) = #2(Elt.value e)
  71       fun setKey(e, k) = Pointer.:=(valuePtr e, (k, value e))
  72
  73       fun siftUp e =
  74          if hasParent e
  75             then let val p = parent e
  76                  in if Key.<(key e, key p)
  77                        then (Pointer.swap(valuePtr e, valuePtr p) ;
  78                              siftUp p)
  79                     else ()
  80                  end
  81          else ()
  82    end
  83
  84 (*--------------------------------------------------------*)
  85 (*                     Heap Datatype                      *)
  86 (*--------------------------------------------------------*)
  87
  88 datatype 'a t = T of {size: int ref,
  89                       roots: (Key.t * 'a) CircList.t,
  90                       min: 'a Elt.t Pointer.t}
  91
  92 fun sizeRef (T{size, ...}) = size
  93 fun size h = !(sizeRef h)
  94 fun setSize(h,n) = sizeRef h := n
  95 fun incSize h = Int.inc(sizeRef h)
  96 fun decSize h = Int.inc(sizeRef h)
  97
  98 fun roots (T{roots, ...}) = roots
  99
 100 fun min(T{min, ...}) = Pointer.! min
 101
 102 fun clearMin(T{min, ...}) = Pointer.clear min
 103
 104 fun updateMin(T{min, ...}, e) =
 105    if Pointer.isNull min orelse Key.<(Elt.key e, Elt.key(Pointer.!min))
 106       then Pointer.:=(min, e)
 107    else ()
 108
 109 fun addRoot(h, e) =
 110    (CircList.insert(roots h, e)
 111     ; updateMin(h, e))
 112
 113 fun isEmpty h = size h = 0
 114
 115 local
 116     fun linkPC(parent, child) =
 117         (Elt.incNumChildren parent
 118          ; CircList.insert(Elt.child parent, child)
 119          ; Elt.setParent(Elt.parent child, parent)
 120          ; Elt.unMark child
 121          ; parent)
 122 in fun link(e, e') =
 123     (* pre: numChildren e = numChildren e' *)
 124    if Key.<(Elt.key e, Elt.key e')
 125       then linkPC(e, e')
 126    else linkPC(e', e)
 127 end
 128
 129 fun unlink e = let val p = Elt.parent e
 130                in Elt.decNumChildren p
 131                   ; CircList.delete(Elt.child p, e)
 132                   ; Elt.clearParent e
 133                   ; Elt.unMark e
 134                end
 135
 136 local
 137    structure I = Int
 138    local open Real
 139    in val phi = (1.0 + (Real.sqrt 5.0)) / 2.0
 140       fun maxNumChildren h = floor(log(phi, fromInt(size h)))
 141    end
 142 in
 143    fun consolidate h =
 144       (clearMin h ;
 145        if size h = 0 then ()
 146        else let val a = Array.new(maxNumChildren h + 1, NONE)
 147                 fun insertIntoA e =
 148                     let val n = Elt.numChildren e
 149                     in case Array.sub(a,n) of
 150                         NONE => Array.update(a,n, SOME e)
 151                       | SOME e' => (Array.update(a,n, NONE)
 152                                     ; insertIntoA(link(e, e')))
 153                     end
 154             in CircList.deleteEach(roots h, insertIntoA)
 155                ; Array.foreach(a, fn NONE => () | SOME e => addRoot(h, e))
 156             end)
 157 end
 158
 159 (*--------------------------------------------------------*)
 160 (*            Constructors: empty, insert, new            *)
 161 (*--------------------------------------------------------*)
 162
 163 fun empty() = T{size = ref 0,
 164                 roots = CircList.empty(),
 165                 min = Pointer.null()}
 166
 167 fun insertLazy(h, k, v) =
 168    let val e = Elt.new(k, v)
 169    in (incSize h ; addRoot(h, e) ; e)
 170    end
 171
 172 fun insertEager(h, k, v) =
 173     let val e = insertLazy(h, k, v)
 174     in (consolidate h ; e)
 175     end
 176
 177 fun newLazy kvs =
 178    let val h = empty()
 179    in (List.foreach(kvs, fn (k, v) => (insertLazy(h, k, v) ; ())) ;
 180        h)
 181    end
 182
 183 fun newEager kvs = let val h = newLazy kvs
 184                    in (consolidate h ; h)
 185                    end
 186
 187 (*--------------------------------------------------------*)
 188 (*                       DeleteMin                        *)
 189 (*--------------------------------------------------------*)
 190
 191 fun deleteMin h =
 192    let val m = min h
 193       val c = Elt.child m
 194       val rs = roots h
 195    in decSize h
 196       ; CircList.delete(rs, m)
 197       ; CircList.foreach(c, Elt.clearParent)
 198       ; CircList.splice(rs, c)
 199       ; consolidate h
 200       ; Elt.value m
 201    end
 202
 203 (*--------------------------------------------------------*)
 204 (*                      DecreaseKey                       *)
 205 (*--------------------------------------------------------*)
 206
 207 fun sift(_, e, _) = Elt.siftUp e
 208
 209 fun cut(h, e, k) =
 210    if Elt.hasParent e
 211       andalso Key.<(k, Elt.key(Elt.parent e))
 212       then let val rs = roots h
 213                fun cut e = if Elt.hasParent e
 214                               then let val p = Elt.parent e
 215                                    in unlink e
 216                                       ; CircList.insert(rs, e)
 217                                       ; if Elt.isMarked p
 218                                            then cut p
 219                                         else Elt.mark p
 220                                    end
 221                            else ()
 222            in cut e
 223            end
 224    else ()
 225
 226 fun decreaseKey(h, e, k) =
 227     if Key.>(k, Elt.key e) then Error.bug "decreaseKey"
 228     else (Elt.setKey(e, k); updateMin(h, e))
 229
 230 fun decreaseKeySift(h, e, k) =
 231    (decreaseKey(h, e, k)
 232     ; sift(h, e, k))
 233
 234 fun decreaseKeyCut(h, e, k) =
 235    (decreaseKey(h, e, k)
 236     ; cut(h, e, k))
 237
 238 (*--------------------------------------------------------*)
 239 (*                         Delete                         *)
 240 (*--------------------------------------------------------*)
 241
 242 fun delete(decreaseKey, h, e) =
 243    let val k = Elt.key e
 244    in decreaseKey(h, e, Key.smallest)
 245       ; deleteMin h
 246       ; Elt.setKey(e, k)
 247    end
 248
 249 fun deleteSift(h, e) = delete(decreaseKeySift, h, e)
 250
 251 fun deleteCut(h, e) = delete(decreaseKeyCut, h, e)
 252
 253 (*--------------------------------------------------------*)
 254 (*                         Union                          *)
 255 (*--------------------------------------------------------*)
 256
 257 fun union(h, h') =
 258     (setSize(h, size h + size h')
 259      ; CircList.splice(roots h, roots h'))
 260
 261 fun unionEager(h, h') = (union(h, h'); consolidate h)
 262
 263 fun unionLazy(h, h') =
 264    (union(h, h')
 265     ; updateMin(h, min h') handle Min => ())
 266
 267 (*--------------------------------------------------------*)
 268 (*                         Output                         *)
 269 (*--------------------------------------------------------*)
 270
 271 fun output(heap, outputValue, out) = Error.unimplemented "output"
 272
 273 (*--------------------------------------------------------*)
 274 (*                    Well-Formed Test                    *)
 275 (*--------------------------------------------------------*)
 276 (*
 277 local
 278    fun sizeInTree e = 1 + sizeInTrees (CircList.T (Elt.children e))
 279    and sizeInTrees l = CircList.fold l 0 (fn (e,n) => n + sizeInTree e)
 280    fun sizeInHeap h = sizeInTrees (roots h)
 281    fun findMin h =
 282       let val min = ref NONE
 283          fun updateMin e = (case !min of
 284                                NONE => min := SOME e
 285                              | SOME e' => if Key.<(Elt.key e, Elt.key e')
 286                                              then min := SOME e
 287                                           else ())
 288       in (CircList.foreach (roots h) updateMin ;
 289           case !min of
 290              SOME e => e
 291            | NONE => bug "findMin")
 292       end
 293    fun isTreeWellFormed e =
 294       let fun isChildWellFormed e' = (Elt.equals(e, Elt.parent e')
 295                                       andalso Key.<=(Elt.key e, Elt.key e')
 296                                       andalso isTreeWellFormed e')
 297          val cs = CircList.T (Elt.children e)
 298       in Elt.numChildren e = CircList.length cs
 299          andalso CircList.forall cs isChildWellFormed
 300       end
 301 in
 302    fun isFibonacciHeap h =
 303       CircList.forall (roots h) isTreeWellFormed
 304       andalso size h = sizeInHeap h
 305       andalso (isEmpty h
 306                orelse Key.equals(Elt.key (min h), Elt.key (findMin h)))
 307 end
 308 *)
 309 end