HCoop / hcoop / debian / mlton.git / blame
| 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 | (* Disjoint Collection *) | |
| 9 | (*-------------------------------------------------------------------*) | |
| 10 | ||
| 11 | functor DisjointCollection(): DISJOINT_COLLECTION = | |
| 12 | struct | |
| 13 | ||
| 14 | structure S = DisjointSet | |
| 15 | structure CL = CircularList | |
| 16 | structure D = SimpleDoublyLinkedElement | |
| 17 | ||
| 18 | structure Value : | |
| 19 | sig | |
| 20 | type 'a t | |
| 21 | val new: '1a -> '1a t | |
| 22 | val value: 'a t -> 'a | |
| 23 | val elt: 'a t -> 'a t S.t D.t | |
| 24 | val set: 'a t -> 'a t S.t | |
| 25 | val copy: 'a t * 'a -> 'a t | |
| 26 | end = | |
| 27 | struct | |
| 28 | datatype 'a t = T of {value: 'a, | |
| 29 | elt: 'a t S.t D.t option ref} | |
| 30 | ||
| 31 | fun value(T{value, ...}) = value | |
| 32 | ||
| 33 | fun elt(T{elt=ref(SOME d), ...}) = d | |
| 34 | | elt _ = Error.error "DisjointCollection.Value.elt" | |
| 35 | ||
| 36 | fun set v = D.value(elt v) | |
| 37 | ||
| 38 | fun new v = let val r = ref NONE | |
| 39 | val v = T{value = v, elt = r} | |
| 40 | val d = D.new(S.singleton v) | |
| 41 | in (r := SOME d ; | |
| 42 | v) | |
| 43 | end | |
| 44 | fun copy(T{elt, ...}, v) = T{value = v, elt = elt} | |
| 45 | end | |
| 46 | structure V = Value | |
| 47 | ||
| 48 | structure S = | |
| 49 | struct | |
| 50 | type 'a t = 'a V.t S.t | |
| 51 | ||
| 52 | fun value s = V.value(S.value s) | |
| 53 | ||
| 54 | fun elt s = V.elt(S.value s) | |
| 55 | ||
| 56 | val representative = S.representative | |
| 57 | val isRepresentative = S.isRepresentative | |
| 58 | val union = S.union | |
| 59 | ||
| 60 | fun setValue(s, v) = S.setValue(s, V.copy(S.value s, v)) | |
| 61 | ||
| 62 | val equals = S.equals | |
| 63 | end | |
| 64 | ||
| 65 | (* ------------------------------------------------- *) | |
| 66 | (* Datatype *) | |
| 67 | (* ------------------------------------------------- *) | |
| 68 | ||
| 69 | datatype 'a t = T of {sets: 'a S.t CL.t, | |
| 70 | numSets: int ref} | |
| 71 | ||
| 72 | fun sets (T{sets, ...}) = sets | |
| 73 | fun numSetsRef (T{numSets, ...}) = numSets | |
| 74 | fun numSets c = !(numSetsRef c) | |
| 75 | fun incNumSets c = numSetsRef c := numSets c + 1 | |
| 76 | fun decNumSets c = numSetsRef c := numSets c - 1 | |
| 77 | ||
| 78 | fun empty() = T{sets = CL.empty(), | |
| 79 | numSets = ref 0} | |
| 80 | ||
| 81 | fun addSingleton(c, v) = | |
| 82 | let val v = V.new v | |
| 83 | in (incNumSets c ; | |
| 84 | CL.insert(sets c, V.elt v) ; | |
| 85 | V.set v) | |
| 86 | end | |
| 87 | ||
| 88 | fun new vs = let val c = empty() | |
| 89 | in (c, List.map(vs, fn v => addSingleton(c, v))) | |
| 90 | end | |
| 91 | ||
| 92 | fun randomSet(T{sets, ...}) = D.value(CL.first sets) | |
| 93 | ||
| 94 | fun random c = S.value(randomSet c) | |
| 95 | ||
| 96 | fun union(c, s, s') = | |
| 97 | let val r = S.representative s | |
| 98 | val d = S.elt r | |
| 99 | val r' = S.representative s' | |
| 100 | val d' = S.elt r' | |
| 101 | in if S.equals(r, r') then () | |
| 102 | else (decNumSets c ; | |
| 103 | S.union(r, r') ; | |
| 104 | CL.delete(sets c, | |
| 105 | if S.isRepresentative r then d' else d)) | |
| 106 | end | |
| 107 | ||
| 108 | end | |
| 109 | ||
| 110 | structure DisjointCollection = DisjointCollection() |