Diff of /smlnj-lib/trunk/HashCons/hash-cons-set.sml

Parent Directory | Revision Log | Patch

	revision 6158, Fri Apr 10 23:22:07 2020 UTC	revision 6159, Sat Apr 11 13:14:51 2020 UTC
#	Line 3	Line 3
3	* COPYRIGHT (c) 2011 The Fellowship of SML/NJ (http://www.smlnj.org)	* COPYRIGHT (c) 2011 The Fellowship of SML/NJ (http://www.smlnj.org)
4	* All rights reserved.	* All rights reserved.
5	*	*
6	* This is an implementation of the HASH_CONS_SET signature that is built	* This is an implementation of the HASH_CONS_SET signature that uses Red-Black
7	* on top of the WordRedBlackMap structure.  Eventually, it will be replaced	* trees.  Eventually, it should be replaced by an implmementation that uses
8	* by an implmementation that uses Patricia trees.	* Patricia trees.
9	*)	*)
10
11	structure HashConsSet : HASH_CONS_SET =	structure HashConsSet : HASH_CONS_SET =
12	struct	struct
13
14	structure HC = HashCons	structure HC = HashCons
15	structure Map = WordRedBlackMap
16		datatype color = R | B
17
18	type 'a obj = 'a HC.obj	type 'a obj = 'a HC.obj
	type 'a set = 'a obj Map.map
19
20	val empty = Map.empty	datatype 'a tree
21	fun singleton obj = Map.singleton(HC.tag obj, obj)	= E
22	fun add  (set, obj) = Map.insert (set, HC.tag obj, obj)	| T of (color * 'a tree * 'a obj * 'a tree)
23	fun add' (obj, set) = Map.insert (set, HC.tag obj, obj)
24	fun addList (set, l) = List.foldl add' set l	datatype 'a set = SET of (int * 'a tree)
25	fun delete (set : 'a set, obj) = #1(Map.remove(set, HC.tag obj))
26	fun member (set, obj) = Map.inDomain(set, HC.tag obj)	(* NOTE: we should use the Word.< and = operations instead of Word.compare *)
27	val isEmpty = Map.isEmpty	fun cmpObj (a : 'a obj, b : 'a obj) = Word.compare(#tag a, #tag b)
28	fun equal (set1, set2) = (case Map.collate (fn _ => EQUAL) (set1, set2)
29	of EQUAL => true	fun isEmpty (SET(_, E)) = true
30		| isEmpty _ = false
31
32		val empty = SET(0, E)
33
34		fun singleton x = SET(1, T(B, E, x, E))
35
36		fun add (SET(nItems, m), x) = let
37		val nItems' = ref nItems
38		fun ins E = (nItems' := nItems+1; T(R, E, x, E))
39		| ins (s as T(color, a, y, b)) = (case cmpObj(x, y)
40		of LESS => (case a
41		of T(R, c, z, d) => (case cmpObj(x, z)
42		of LESS => (case ins c
43		of T(R, e, w, f) => T(R, T(B,e,w,f), z, T(B,d,y,b))
44		| c => T(B, T(R,c,z,d), y, b)
45		(* end case *))
46		| EQUAL => T(color, T(R, c, x, d), y, b)
47		| GREATER => (case ins d
48		of T(R, e, w, f) => T(R, T(B,c,z,e), w, T(B,f,y,b))
49		| d => T(B, T(R,c,z,d), y, b)
50		(* end case *))
51		(* end case *))
52		| _ => T(B, ins a, y, b)
53		(* end case *))
54		| EQUAL => T(color, a, x, b)
55		| GREATER => (case b
56		of T(R, c, z, d) => (case cmpObj(x, z)
57		of LESS => (case ins c
58		of T(R, e, w, f) => T(R, T(B,a,y,e), w, T(B,f,z,d))
59		| c => T(B, a, y, T(R,c,z,d))
60		(* end case *))
61		| EQUAL => T(color, a, y, T(R, c, x, d))
62		| GREATER => (case ins d
63		of T(R, e, w, f) => T(R, T(B,a,y,c), z, T(B,e,w,f))
64		| d => T(B, a, y, T(R,c,z,d))
65		(* end case *))
66		(* end case *))
67		| _ => T(B, a, y, ins b)
68		(* end case *))
69		(* end case *))
70		val T(_, a, y, b) = ins m
71		in
72		SET(!nItems', T(B, a, y, b))
73		end
74		fun add' (x, m) = add (m, x)
75
76		fun addList (s, []) = s
77		| addList (s, x::r) = addList(add(s, x), r)
78
79		(* Remove an item.  Raises LibBase.NotFound if not found. *)
80		local
81		datatype 'a zipper
82		= TOP
83		| LEFT of (color * 'a obj * 'a tree * 'a zipper)
84		| RIGHT of (color * 'a tree * 'a obj * 'a zipper)
85		in
86		fun delete (SET(nItems, t), k) = let
87		(* zip the zipper *)
88		fun zip (TOP, t) = t
89		| zip (LEFT(color, x, b, p), a) = zip(p, T(color, a, x, b))
90		| zip (RIGHT(color, a, x, p), b) = zip(p, T(color, a, x, b))
91		(* zip the zipper while resolving a black deficit *)
92		fun fixupZip (TOP, t) = (true, t)
93		(* case 1 from CLR *)
94		| fixupZip (LEFT(B, x, T(R, a, y, b), p), t) = (case a
95		of T(_, T(R, a11, w, a12), z, a2) => (* case 1L ==> case 3L ==> case 4L *)
96		(false, zip (p, T(B, T(R, T(B, t, x, a11), w, T(B, a12, z, a2)), y, b)))
97		| T(_, a1, z, T(R, a21, w, t22)) => (* case 1L ==> case 4L *)
98		(false, zip (p, T(B, T(R, T(B, t, x, a1), z, T(B, a21, w, t22)), y, b)))
99		| T(_, a1, z, a2) => (* case 1L ==> case 2L; rotate + recolor fixes deficit *)
100		(false, zip (p, T(B, T(B, t, x, T(R, a1, z, a2)), y, b)))
101		| _ => fixupZip (LEFT(R, x, a, LEFT(B, y, b, p)), t)
102		(* end case *))
103		| fixupZip (RIGHT(B, T(R, a, x, b), y, p), t) = (case b
104		of T(_, b1, z, T(R, b21, w, b22)) => (* case 1R ==> case 3R ==> case 4R *)
105		(false, zip (p, T(B, a, x, T(R, T(B, b1, z, b21), w, T(B, b22, y, t)))))
106		| T(_, T(R, b11, w, b12), z, b2) => (* case 1R ==> case 4R *)
107		(false, zip (p, T(B, a, x, T(R, T(B, b11, w, b12), z, T(B, b2, y, t)))))
108		| T(_, b1, z, b2) => (* case 1L ==> case 2L; rotate + recolor fixes deficit *)
109		(false, zip (p, T(B, a, x, T(B, T(R, b1, z, b2), y, t))))
110		| _ => fixupZip (RIGHT(R, b, y, RIGHT(B, a, x, p)), t)
111		(* end case *))
112		(* case 3 from CLR *)
113		| fixupZip (LEFT(color, x, T(B, T(R, a1, y, a2), z, b), p), t) =
114		(* case 3L ==> case 4L *)
115		(false, zip (p, T(color, T(B, t, x, a1), y, T(B, a2, z, b))))
116		| fixupZip (RIGHT(color, T(B, a, x, T(R, b1, y, b2)), z, p), t) =
117		(* case 3R ==> case 4R; rotate, recolor, plus rotate fixes deficit *)
118		(false, zip (p, T(color, T(B, a, x, b1), y, T(B, b2, z, t))))
119		(* case 4 from CLR *)
120		| fixupZip (LEFT(color, x, T(B, a, y, T(R, b1, z, b2)), p), t) =
121		(false, zip (p, T(color, T(B, t, x, a), y, T(B, b1, z, b2))))
122		| fixupZip (RIGHT(color, T(B, T(R, a1, z, a2), x, b), y, p), t) =
123		(false, zip (p, T(color, T(B, a1, z, a2), x, T(B, b, y, t))))
124		(* case 2 from CLR; note that "a" and "b" are guaranteed to be black, since we did
125		* not match cases 3 or 4.
126		*)
127		| fixupZip (LEFT(R, x, T(B, a, y, b), p), t) =
128		(false, zip (p, T(B, t, x, T(R, a, y, b))))
129		| fixupZip (LEFT(B, x, T(B, a, y, b), p), t) =
130		fixupZip (p, T(B, t, x, T(R, a, y, b)))
131		| fixupZip (RIGHT(R, T(B, a, x, b), y, p), t) =
132		(false, zip (p, T(B, T(R, a, x, b), y, t)))
133		| fixupZip (RIGHT(B, T(B, a, x, b), y, p), t) =
134		fixupZip (p, T(B, T(R, a, x, b), y, t))
135		(* push deficit up the tree by recoloring a black node as red *)
136		| fixupZip (LEFT(_, y, E, p), t) = fixupZip (p, T(R, t, y, E))
137		| fixupZip (RIGHT(_, E, y, p), t) = fixupZip (p, T(R, E, y, t))
138		(* impossible cases that violate the red invariant *)
139		| fixupZip _ = raise Fail "Red invariant violation"
140		(* delete the minimum value from a non-empty tree, returning a triple
141		* (elem, bd, tr), where elem is the minimum element, tr is the residual
142		* tree with elem removed, and bd is true if tr has a black-depth that is
143		* less than the original tree.
144		*)
145		fun delMin (T(R, E, y, b), p) =
146		(* replace the node by its right subtree (which must be E) *)
147		(y, false, zip(p, b))
148		| delMin (T(B, E, y, T(R, a', y', b')), p) =
149		(* replace the node with its right child, while recoloring the child black to
150		* preserve the black invariant.
151		*)
152		(y, false, zip (p, T(B, a', y', b')))
153		| delMin (T(B, E, y, E), p) = let
154		(* delete the node, which reduces the black-depth by one, so we attempt to fix
155		* the deficit on the path back.
156		*)
157		val (blkDeficit, t) = fixupZip (p, E)
158		in
159		(y, blkDeficit, t)
160		end
161		| delMin (T(color, a, y, b), z) = delMin(a, LEFT(color, y, b, z))
162		| delMin (E, _) = raise Match
163		fun del (E, z) = raise LibBase.NotFound
164		| del (T(color, a, y, b), p) = (case cmpObj(k, y)
165		of LESS => del (a, LEFT(color, y, b, p))
166		| EQUAL => (case (color, a, b)
167		of (R, E, E) => zip(p, E)
168		| (B, E, E) => #2 (fixupZip (p, E))
169		| (_, T(_, a', y', b'), E) =>
170		(* node is black and left child is red; we replace the node with its
171		* left child recolored to black.
172		*)
173		zip(p, T(B, a', y', b'))
174		| (_, E, T(_, a', y', b')) =>
175		(* node is black and right child is red; we replace the node with its
176		* right child recolored to black.
177		*)
178		zip(p, T(B, a', y', b'))
179		| _ => let
180		val (minSucc, blkDeficit, b) = delMin (b, TOP)
181		in
182		if blkDeficit
183		then #2 (fixupZip (RIGHT(color, a, minSucc, p), b))
184		else zip (p, T(color, a, minSucc, b))
185		end
186		(* end case *))
187		| GREATER => del (b, RIGHT(color, a, y, p))
188		(* end case *))
189		in
190		case del(t, TOP)
191		of T(R, a, x, b) => SET(nItems-1, T(B, a, x, b))
192		| t => SET(nItems-1, t)
193		(* end case *)
194		end
195		end (* local *)
196
197		(* Return true if and only if item is an element in the set *)
198		fun member (SET(_, t), k) = let
199		fun find' E = false
200		| find' (T(_, a, y, b)) = (case cmpObj(k, y)
201		of LESS => find' a
202		| EQUAL => true
203		| GREATER => find' b
204		(* end case *))
205		in
206		find' t
207		end
208
209		(* Return the number of items in the map *)
210		fun numItems (SET(n, _)) = n
211
212		fun fold f = let
213		fun foldf (E, accum) = accum
214		| foldf (T(_, a, x, b), accum) =
215		foldf(b, f(x, foldf(a, accum)))
216		in
217		fn init => fn (SET(_, m)) => foldf(m, init)
218		end
219
220		val foldl = fold    (* DEPRECATED *)
221		val foldr = fold    (* DEPRECATED *)
222
223		(* return an ordered list of the items in the set. *)
224		fun toList s = foldr (fn (x, l) => x::l) [] s
225
226		(* functions for walking the tree while keeping a stack of parents
227		* to be visited.
228		*)
229		fun next ((t as T(_, _, _, b))::rest) = (t, left(b, rest))
230		| next _ = (E, [])
231		and left (E, rest) = rest
232		| left (t as T(_, a, _, _), rest) = left(a, t::rest)
233		fun start m = left(m, [])
234
235		(* Return true if and only if the two sets are equal *)
236		fun equal (SET(_, s1), SET(_, s2)) = let
237		fun cmp (t1, t2) = (case (next t1, next t2)
238		of ((E, _), (E, _)) => true
239		| ((E, _), _) => false
240		| (_, (E, _)) => false
241		| ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
242		case cmpObj(x, y)
243		of EQUAL => cmp (r1, r2)
244	| _ => false	| _ => false
245	(* end case *))	(* end case *))
246	fun compare arg = Map.collate (fn _ => EQUAL) arg	(* end case *))
247		in
248		cmp (start s1, start s2)
249		end
250
251		(* Return the lexical order of two sets *)
252		fun compare (SET(_, s1), SET(_, s2)) = let
253		fun cmp (t1, t2) = (case (next t1, next t2)
254		of ((E, _), (E, _)) => EQUAL
255		| ((E, _), _) => LESS
256		| (_, (E, _)) => GREATER
257		| ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
258		case cmpObj(x, y)
259		of EQUAL => cmp (r1, r2)
260		| order => order
261		(* end case *))
262		(* end case *))
263		in
264		cmp (start s1, start s2)
265		end
266
267		(* Return true if and only if the first set is a subset of the second *)
268		fun isSubset (SET(_, s1), SET(_, s2)) = let
269		fun cmp (t1, t2) = (case (next t1, next t2)
270		of ((E, _), (E, _)) => true
271		| ((E, _), _) => true
272		| (_, (E, _)) => false
273		| ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
274		case cmpObj(x, y)
275		of LESS => false
276		| EQUAL => cmp (r1, r2)
277		| GREATER => cmp (t1, r2)
278		(* end case *))
279		(* end case *))
280		in
281		cmp (start s1, start s2)
282		end
283
284		(* Return true if the two sets are disjoint *)
285		fun disjoint (SET(0, _), _) = true
286		| disjoint (_, SET(0, _)) = true
287		| disjoint (SET(_, s1), SET(_, s2)) = let
288		fun walk ((E, _), _) = true
289		| walk (_, (E, _)) = true
290		| walk (t1 as (T(_, _, x, _), r1), t2 as (T(_, _, y, _), r2)) = (
291		case cmpObj(x, y)
292		of LESS => walk (next r1, t2)
293		| EQUAL => false
294		| GREATER => walk (t1, next r2)
295		(* end case *))
296		in
297		walk (next (start s1), next (start s2))
298		end
299
300		(* support for constructing red-black trees in linear time from increasing
301		* ordered sequences (based on a description by R. Hinze).  Note that the
302		* elements in the digits are ordered with the largest on the left, whereas
303		* the elements of the trees are ordered with the largest on the right.
304		*)
305		datatype 'a digit
306		= ZERO
307		| ONE of ('a obj * 'a tree * 'a digit)
308		| TWO of ('a obj * 'a tree * 'a obj * 'a tree * 'a digit)
309		(* add an item that is guaranteed to be larger than any in l *)
310		fun addItem (a, l) = let
311		fun incr (a, t, ZERO) = ONE(a, t, ZERO)
312		| incr (a1, t1, ONE(a2, t2, r)) = TWO(a1, t1, a2, t2, r)
313		| incr (a1, t1, TWO(a2, t2, a3, t3, r)) =
314		ONE(a1, t1, incr(a2, T(B, t3, a3, t2), r))
315		in
316		incr(a, E, l)
317		end
318		(* link the digits into a tree *)
319		fun linkAll t = let
320		fun link (t, ZERO) = t
321		| link (t1, ONE(a, t2, r)) = link(T(B, t2, a, t1), r)
322		| link (t, TWO(a1, t1, a2, t2, r)) =
323		link(T(B, T(R, t2, a2, t1), a1, t), r)
324		in
325		link (E, t)
326		end
327
328		(* create a set from a list of items; this function works in linear time if the list
329		* is in increasing order.
330		*)
331		fun fromList [] = empty
332		| fromList (first::rest) = let
333		fun add (prev, x::xs, n, accum) = (case cmpObj(prev, x)
334		of LESS => add(x, xs, n+1, addItem(x, accum))
335		| _ => (* list not in order, so fall back to addList code *)
336		addList(SET(n, linkAll accum), x::xs)
337		(* end case *))
338		| add (_, [], n, accum) = SET(n, linkAll accum)
339		in
340		add (first, rest, 1, addItem(first, ZERO))
341		end
342
343		(* return the union of the two sets *)
344		fun union (SET(_, s1), SET(_, s2)) = let
345		fun ins ((E, _), n, result) = (n, result)
346		| ins ((T(_, _, x, _), r), n, result) =
347		ins(next r, n+1, addItem(x, result))
348		fun union' (t1, t2, n, result) = (case (next t1, next t2)
349		of ((E, _), (E, _)) => (n, result)
350		| ((E, _), t2) => ins(t2, n, result)
351		| (t1, (E, _)) => ins(t1, n, result)
352		| ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
353		case cmpObj(x, y)
354		of LESS => union' (r1, t2, n+1, addItem(x, result))
355		| EQUAL => union' (r1, r2, n+1, addItem(x, result))
356		| GREATER => union' (t1, r2, n+1, addItem(y, result))
357		(* end case *))
358		(* end case *))
359		val (n, result) = union' (start s1, start s2, 0, ZERO)
360		in
361		SET(n, linkAll result)
362		end
363
364		(* return the intersection of the two sets *)
365		fun intersection (SET(_, s1), SET(_, s2)) = let
366		fun intersect (t1, t2, n, result) = (case (next t1, next t2)
367		of ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
368		case cmpObj(x, y)
369		of LESS => intersect (r1, t2, n, result)
370		| EQUAL => intersect (r1, r2, n+1, addItem(x, result))
371		| GREATER => intersect (t1, r2, n, result)
372		(* end case *))
373		| _ => (n, result)
374		(* end case *))
375		val (n, result) = intersect (start s1, start s2, 0, ZERO)
376		in
377		SET(n, linkAll result)
378		end
379
380		(* return the set difference *)
381		fun difference (SET(_, s1), SET(_, s2)) = let
382		fun ins ((E, _), n, result) = (n, result)
383		| ins ((T(_, _, x, _), r), n, result) =
384		ins(next r, n+1, addItem(x, result))
385		fun diff (t1, t2, n, result) = (case (next t1, next t2)
386		of ((E, _), _) => (n, result)
387		| (t1, (E, _)) => ins(t1, n, result)
388		| ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
389		case cmpObj(x, y)
390		of LESS => diff (r1, t2, n+1, addItem(x, result))
391		| EQUAL => diff (r1, r2, n, result)
392		| GREATER => diff (t1, r2, n, result)
393		(* end case *))
394		(* end case *))
395		val (n, result) = diff (start s1, start s2, 0, ZERO)
396		in
397		SET(n, linkAll result)
398		end
399
400		fun subtract (s, item) = difference (s, singleton item)
401		fun subtract' (item, s) = subtract (s, item)
402
403		fun subtractList (l, items) = let
404		val items' = List.foldl (fn (x, set) => add(set, x)) (SET(0, E)) items
405		in
406		difference (l, items')
407		end
408
409		fun app f = let
410		fun appf E = ()
411		| appf (T(_, a, x, b)) = (appf a; f x; appf b)
412		in
413		fn (SET(_, m)) => appf m
414		end
415
416		fun map f = let
417		fun addf (x, m) = add(m, f x)
418		in
419		foldl addf empty
420		end
421
422		fun mapPartial f (SET(_, m)) = let
423		fun mapf (E, acc) = acc
424		| mapf (T(_, a, x, b), acc) = (case f x
425		of SOME y => mapf (b, mapf (a, add (acc, y)))
426		| NONE => mapf (b, mapf (a, acc))
427		(* end case *))
428		in
429		mapf (m, empty)
430		end
431
432	fun isSubset _ = raise Fail "isSubset"	(* Filter out those elements of the set that do not satisfy the
433		* predicate.  The filtering is done in increasing map order.
434		*)
435		fun filter pred (SET(_, t)) = let
436		fun walk (E, n, result) = (n, result)
437		| walk (T(_, a, x, b), n, result) = let
438		val (n, result) = walk(a, n, result)
439		in
440		if (pred x)
441		then walk(b, n+1, addItem(x, result))
442		else walk(b, n, result)
443		end
444		val (n, result) = walk (t, 0, ZERO)
445		in
446		SET(n, linkAll result)
447		end
448
449	val numItems = Map.numItems	fun partition pred (SET(_, t)) = let
450	val listItems = Map.listItems	fun walk (E, n1, result1, n2, result2) = (n1, result1, n2, result2)
451	fun union arg = Map.unionWith (fn (a, _) => a) arg	| walk (T(_, a, x, b), n1, result1, n2, result2) = let
452	fun intersection arg = Map.intersectWith (fn (a, _) => a) arg	val (n1, result1, n2, result2) = walk(a, n1, result1, n2, result2)
453		in
454		if (pred x)
455		then walk(b, n1+1, addItem(x, result1), n2, result2)
456		else walk(b, n1, result1, n2+1, addItem(x, result2))
457		end
458		val (n1, result1, n2, result2) = walk (t, 0, ZERO, 0, ZERO)
459		in
460		(SET(n1, linkAll result1), SET(n2, linkAll result2))
461		end
462
463	fun difference _ = raise Fail "difference"	fun exists pred = let
464		fun test E = false
465		| test (T(_, a, x, b)) = test a orelse pred x orelse test b
466		in
467		fn (SET(_, t)) => test t
468		end
469
470	val map = Map.map	fun all pred = let
471	val mapPartial = Map.mapPartial	fun test E = true
472	val app = Map.app	| test (T(_, a, x, b)) = test a andalso pred x andalso test b
473	val foldl = Map.foldl	in
474	val foldr = Map.foldr	fn (SET(_, t)) => test t
475		end
476
477	fun partition _ = raise Fail "partition"	fun find pred = let
478		fun test E = NONE
479		| test (T(_, a, x, b)) = (case test a
480		of NONE => if pred x then SOME x else test b
481		| someItem => someItem
482		(* end case *))
483		in
484		fn (SET(_, t)) => test t
485		end
486
487	val filter = Map.filter	(* deprecated *)
488	fun exists pred set = List.exists pred (listItems set)	val listItems = toList
	fun find pred set = List.find pred (listItems set)
489
490	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.6158   changed lines   Added in v.6159

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0