Mercurial > urweb
comparison src/union_find_fn.sml @ 2216:70ec9bb337be
Progress towards invalidation based on equalities of fields.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Mon, 10 Nov 2014 22:04:40 -0500 |
| parents | |
| children | ff38b3e0cdfd |
comparison
equal
deleted
inserted
replaced
| 2215:639e62ca2530 | 2216:70ec9bb337be |
|---|---|
| 1 functor UnionFindFn(K : ORD_KEY) = struct | |
| 2 | |
| 3 structure M = BinaryMapFn(K) | |
| 4 structure S = BinarySetFn(K) | |
| 5 | |
| 6 datatype entry = | |
| 7 Set of S.set | |
| 8 | Pointer of K.ord_key | |
| 9 | |
| 10 (* First map is the union-find tree, second stores equivalence classes. *) | |
| 11 type unionFind = entry M.map ref * S.set M.map | |
| 12 | |
| 13 val empty : unionFind = (ref M.empty, M.empty) | |
| 14 | |
| 15 fun findPair (uf, x) = | |
| 16 case M.find (!uf, x) of | |
| 17 NONE => (S.singleton x, x) | |
| 18 | SOME (Set set) => (set, x) | |
| 19 | SOME (Pointer parent) => | |
| 20 let | |
| 21 val (set, rep) = findPair (uf, parent) | |
| 22 in | |
| 23 uf := M.insert (!uf, x, Pointer rep); | |
| 24 (set, rep) | |
| 25 end | |
| 26 | |
| 27 fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x) | |
| 28 | |
| 29 fun classes (_, cs) = (map S.listItems o M.listItems) cs | |
| 30 | |
| 31 fun union ((uf, cs), x, y) = | |
| 32 let | |
| 33 val (xSet, xRep) = findPair (uf, x) | |
| 34 val (ySet, yRep) = findPair (uf, y) | |
| 35 val xySet = S.union (xSet, ySet) | |
| 36 in | |
| 37 (ref (M.insert (M.insert (!uf, yRep, Pointer xRep), | |
| 38 xRep, Set xySet)), | |
| 39 M.insert (case M.find (cs, yRep) of | |
| 40 NONE => cs | |
| 41 | SOME _ => #1 (M.remove (cs, yRep)), | |
| 42 xRep, xySet)) | |
| 43 end | |
| 44 | |
| 45 fun union' ((x, y), uf) = union (uf, x, y) | |
| 46 | |
| 47 end |