Mercurial > urweb

comparison src/union_find_fn.sml @ 2304:6fb9232ade99

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge Sqlcache
author Adam Chlipala <adam@chlipala.net>
date Sun, 20 Dec 2015 14:18:52 -0500
parents 0730e217fc9c
children
comparison
equal deleted inserted replaced
2201:1091227f535a 2304:6fb9232ade99
1 functor UnionFindFn(K : ORD_KEY) :> sig
2 type unionFind
3 val empty : unionFind
4 val union : unionFind * K.ord_key * K.ord_key -> unionFind
5 val union' : (K.ord_key * K.ord_key) * unionFind -> unionFind
6 val together : unionFind * K.ord_key * K.ord_key -> bool
7 val classes : unionFind -> K.ord_key list list
8 end = struct
9
10 structure M = BinaryMapFn(K)
11 structure S = BinarySetFn(K)
12
13 datatype entry =
14 Set of S.set
15 | Pointer of K.ord_key
16
17 (* First map is the union-find tree, second stores equivalence classes. *)
18 type unionFind = entry M.map ref * S.set M.map
19
20 val empty : unionFind = (ref M.empty, M.empty)
21
22 fun findPair (uf, x) =
23 case M.find (!uf, x) of
24 NONE => (S.singleton x, x)
25 | SOME (Set set) => (set, x)
26 | SOME (Pointer parent) =>
27 let
28 val (set, rep) = findPair (uf, parent)
29 in
30 uf := M.insert (!uf, x, Pointer rep);
31 (set, rep)
32 end
33
34 fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x)
35
36 fun classes (_, cs) = (map S.listItems o M.listItems) cs
37
38 fun together ((uf, _), x, y) = case K.compare (#2 (findPair (uf, x)), #2 (findPair (uf, y))) of
39 EQUAL => true
40 | _ => false
41
42 fun union ((uf, cs), x, y) =
43 let
44 val (xSet, xRep) = findPair (uf, x)
45 val (ySet, yRep) = findPair (uf, y)
46 val xySet = S.union (xSet, ySet)
47 in
48 (ref (M.insert (M.insert (!uf, yRep, Pointer xRep),
49 xRep, Set xySet)),
50 M.insert (case M.find (cs, yRep) of
51 NONE => cs
52 | SOME _ => #1 (M.remove (cs, yRep)),
53 xRep, xySet))
54 end
55
56 fun union' ((x, y), uf) = union (uf, x, y)
57
58 end