Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |