lib/mlton/set/disjoint-max.fun

   1 (* Copyright (C) 1999-2006 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 (* Taken from
   9  * Applications of Path Compression on Balanced Trees
  10  * Robert Endre Tarjan
  11  * JACM, 26, 4
  12  * October 1979
  13  * 690-715
  14  *)
  15
  16 functor DisjointMax(O: ORDER): DISJOINT_MAX =
  17 struct
  18
  19 structure O = O
  20
  21 datatype t = T of {label: O.t ref,
  22                    info: info ref}
  23 and info =
  24    Parent of t
  25   | Root of {size: int ref,
  26              child: t option ref}
  27
  28 fun parent (T{info = ref (Parent p), ...}) = p
  29   | parent _ = Error.bug "DisjointMax.parent"
  30 fun setParent(T{info, ...}, p) = info := Parent p
  31 fun labelRef (T{label, ...}) = label
  32 val (label, setLabel) = Ref.getAndSet labelRef
  33 fun sizeRef (T{info = ref(Root{size, ...}), ...}) = size
  34   | sizeRef _ = Error.bug "DisjointMax.sizeRef"
  35 val (size, setSize) = Ref.getAndSet sizeRef
  36 fun childRef (T{info = ref(Root{child, ...}), ...}) = child
  37   | childRef _ = Error.bug "DisjointMax.childRef"
  38 val (childOption, setChildOption) = Ref.getAndSet childRef
  39 val child = Option.projector childOption
  40 fun setChild(r, c) = setChildOption(r, SOME c)
  41
  42 fun subsize r = size r - (case childOption r of
  43                              NONE => 0
  44                            | SOME r' => size r')
  45
  46 fun hasParent (T{info = ref (Parent _), ...}) = true
  47   | hasParent _ = false
  48
  49 fun isRoot (T{info = ref (Root _), ...}) = true
  50   | isRoot _ = false
  51
  52 fun singleton l = T{label = ref l,
  53                     info = ref (Root{size = ref 0, child = ref NONE})}
  54
  55 fun update(r, l) =
  56    if not(isRoot r) then Error.error "DisjointMax.update"
  57    else if O.<=(l, label r) then ()
  58    else let
  59            fun link r =
  60               case childOption r of
  61                  NONE => r
  62                | SOME r' =>
  63                      if O.<=(l, label r') then r
  64                      else if subsize r >= subsize r'
  65                               then (setChildOption(r, childOption r') ;
  66                                     setParent(r', r) ;
  67                                     link r)
  68                           else (setSize(r', size r) ;
  69                                 setParent(r, r') ;
  70                                 link r')
  71         in (setLabel(r, l) ;
  72             case childOption r of
  73                NONE => ()
  74              | SOME r' => if O.<=(l, label r') then ()
  75                           else let val r' = link r'
  76                                in (setChild(r, r') ;
  77                                    setLabel(r', l))
  78                                end)
  79         end
  80
  81 fun link(r, r') =
  82    if not (isRoot r andalso isRoot r') then Error.error "DisjointMax.link"
  83    else let val s = size r
  84             val s' = size r'
  85             fun move NONE = ()
  86               | move (SOME r') = let val r'' = childOption r'
  87                                  in (setParent(r', r) ; move r'')
  88                                  end
  89         in (update(r', label r) ;
  90             setSize(r, s + s') ;
  91             if s < s' then move (childOption r) else move (SOME r'))
  92         end
  93
  94 fun compress s = (* Pre: hasParent s *)
  95    let val p = parent s
  96    in if hasParent p
  97       then (compress p ;
  98             setLabel(s, O.max(label s, label p)) ;
  99             setParent(s, parent p))
 100       else ()
 101    end
 102
 103 fun eval s = if isRoot s then label s
 104              else (compress s ;
 105                    O.max(label s, label (parent s)))
 106
 107 end