1(* Intset -- modified for Moscow ML from SML/NJ library v. 0.2.
2 *
3 * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.
4 * See file mosml/copyrght/copyrght.att for details.
5 *
6 * This code was adapted from Stephen Adams' binary tree implementation
7 * of applicative integer sets.
8 *
9 *  Copyright 1992 Stephen Adams.
10 *
11 *  This software may be used freely provided that:
12 *    1. This copyright notice is attached to any copy, derived work,
13 *       or work including all or part of this software.
14 *    2. Any derived work must contain a prominent notice stating that
15 *       it has been altered from the original.
16 *
17 *  Altered to conform to SML library interface - Emden Gansner
18 *
19 *
20 * Name(s): Stephen Adams.
21 * Department, Institution: Electronics & Computer Science,
22 *    University of Southampton
23 * Address:  Electronics & Computer Science
24 *           University of Southampton
25 *           Southampton  SO9 5NH
26 *           Great Britian
27 * E-mail:   sra@ecs.soton.ac.uk
28 *
29 * Comments:
30 *
31 *   1.  The implementation is based on Binary search trees of Bounded
32 *       Balance, similar to Nievergelt & Reingold, SIAM J. Computing
33 *       2(1), March 1973.  The main advantage of these trees is that
34 *       they keep the size of the tree in the node, giving a constant
35 *       time size operation.
36 *
37 *   2.  The bounded balance criterion is simpler than N&R's alpha.
38 *       Simply, one subtree must not have more than `weight' times as
39 *       many elements as the opposite subtree.  Rebalancing is
40 *       guaranteed to reinstate the criterion for weight>2.23, but
41 *       the occasional incorrect behaviour for weight=2 is not
42 *       detrimental to performance.
43 *
44 *   3.  There are two implementations of union.  The default,
45 *       hedge_union, is much more complex and usually 20% faster.  I
46 *       am not sure that the performance increase warrants the
47 *       complexity (and time it took to write), but I am leaving it
48 *       in for the competition.  It is derived from the original
49 *       union by replacing the split_lt(gt) operations with a lazy
50 *       version. The `obvious' version is called old_union.
51 *
52 *   4.  Most time is spent in T', the rebalancing constructor.  If my
53 *       understanding of the output of *<file> in the sml batch
54 *       compiler is correct then the code produced by NJSML 0.75
55 *       (sparc) for the final case is very disappointing.  Most
56 *       invocations fall through to this case and most of these cases
57 *       fall to the else part, i.e. the plain contructor,
58 *       T(v,ln+rn+1,l,r).  The poor code allocates a 16 word vector
59 *       and saves lots of registers into it.  In the common case it
60 *       then retrieves a few of the registers and allocates the 5
61 *       word T node.  The values that it retrieves were live in
62 *       registers before the massive save.
63 *)
64
65structure Intset :> Intset =
66struct
67
68fun wt (i : int) = 3 * i
69
70datatype Set = E | T of int * int * Set * Set
71
72fun size E = 0
73  | size (T(_,n,_,_)) = n
74
75(*fun N(v,l,r) = T(v,1+size(l)+size(r),l,r)*)
76fun N(v,E,              E)               = T(v,1,E,E)
77  | N(v,E,              r as T(_,n,_,_)) = T(v,n+1,E,r)
78  | N(v,l as T(_,n,_,_),E)               = T(v,n+1,l,E)
79  | N(v,l as T(_,n,_,_),r as T(_,m,_,_)) = T(v,n+m+1,l,r)
80
81fun single_L (a,x,T(b,_,y,z)) = N(b,N(a,x,y),z)
82  | single_L _ = raise Match
83fun single_R (b,T(a,_,x,y),z) = N(a,x,N(b,y,z))
84  | single_R _ = raise Match
85fun double_L (a,w,T(c,_,T(b,_,x,y),z)) = N(b,N(a,w,x),N(c,y,z))
86  | double_L _ = raise Match
87fun double_R (c,T(a,_,w,T(b,_,x,y)),z) = N(b,N(a,w,x),N(c,y,z))
88  | double_R _ = raise Match
89
90fun T' (v,E,E) = T(v,1,E,E)
91  | T' (v,E,r as T(_,_,E,E))     = T(v,2,E,r)
92  | T' (v,l as T(_,_,E,E),E)     = T(v,2,l,E)
93
94  | T' (p as (_,E,T(_,_,T(_,_,_,_),E))) = double_L p
95  | T' (p as (_,T(_,_,E,T(_,_,_,_)),E)) = double_R p
96
97  (* these cases almost never happen with small weight*)
98  | T' (p as (_,E,T(_,_,T(_,ln,_,_),T(_,rn,_,_)))) =
99        if ln<rn then single_L p else double_L p
100  | T' (p as (_,T(_,_,T(_,ln,_,_),T(_,rn,_,_)),E)) =
101        if ln>rn then single_R p else double_R p
102
103  | T' (p as (_,E,T(_,_,E,_)))  = single_L p
104  | T' (p as (_,T(_,_,_,E),E))  = single_R p
105
106  | T' (p as (v,l as T(lv,ln,ll,lr),r as T(rv,rn,rl,rr))) =
107        if rn>=wt ln then (*right is too big*)
108            let val rln = size rl
109                val rrn = size rr
110            in
111                if rln < rrn then  single_L p  else  double_L p
112            end
113
114        else if ln>=wt rn then  (*left is too big*)
115            let val lln = size ll
116                val lrn = size lr
117            in
118                if lrn < lln then  single_R p  else  double_R p
119            end
120
121        else
122         T(v,ln+rn+1,l,r)
123
124fun addt t x =
125    let fun h E = T(x,1,E,E)
126          | h (set as T(v,_,l,r)) =
127            if x<v then T'(v, h l, r)
128            else if x>v then T'(v, l, h r)
129            else set
130    in h t end
131
132fun concat3 E v r = addt r v
133  | concat3 l v E = addt l v
134  | concat3 (l as T(v1,n1,l1,r1)) v (r as T(v2,n2,l2,r2)) =
135    if wt n1 < n2 then T'(v2, concat3 l v l2,r2)
136    else if wt n2 < n1 then T'(v1,l1,concat3 r1 v r)
137    else N(v,l,r)
138
139fun split_lt E x = E
140  | split_lt (t as T(v,_,l,r)) x =
141    if v>x then split_lt l x
142    else if v<x then concat3 l v (split_lt r x)
143    else l
144
145fun split_gt E x = E
146  | split_gt (t as T(v,_,l,r)) x =
147    if v<x then split_gt r x
148    else if v>x then concat3 (split_gt l x) v r
149    else r
150
151fun min (T(v,_,E,_)) = v
152  | min (T(v,_,l,_)) = min l
153  | min _            = raise Match
154and delete' (E,r) = r
155  | delete' (l,E) = l
156  | delete' (l,r) =
157    let val min_elt = min r
158    in T'(min_elt,l,delmin r) end
159and delmin (T(_,_,E,r)) = r
160  | delmin (T(v,_,l,r)) = T'(v,delmin l,r)
161  | delmin _ = raise Match
162
163fun concat E  s2 = s2
164  | concat s1 E  = s1
165  | concat (t1 as T(v1,n1,l1,r1)) (t2 as T(v2,n2,l2,r2)) =
166        if wt n1 < n2 then T'(v2, concat t1 l2, r2)
167        else if wt n2 < n1 then T'(v1,l1, concat r1 t2)
168             else T'(min t2,t1, delmin t2)
169
170type  intset = Set
171
172exception NotFound
173
174val empty = E
175
176fun singleton x = T(x,1,E,E)
177
178local
179    fun trim lo hi E = E
180      | trim lo hi (s as T(v,_,l,r)) =
181        if  v<=lo  then  trim lo hi r
182        else if  v>=hi  then  trim lo hi l
183        else  s
184
185    fun uni_bd s E lo hi = s
186      | uni_bd E (T(v,_,l,r)) lo hi =
187        concat3 (split_gt l lo) v (split_lt r hi)
188      | uni_bd (T(v,_,l1,r1)) (s2 as T(v2,_,l2,r2)) lo hi =
189        concat3 (uni_bd l1 (trim lo v s2) lo v)
190                v
191                (uni_bd r1 (trim v hi s2) v hi)
192    (* inv:  lo < v < hi *)
193
194   (*all the other versions of uni and trim are
195   specializations of the above two functions with
196   lo=-infinity and/or hi=+infinity *)
197
198    fun trim_lo _ E = E
199      | trim_lo lo (s as T(v,_,_,r)) =
200        if v<=lo then trim_lo lo r else s
201    fun trim_hi _ E = E
202      | trim_hi hi (s as T(v,_,l,_)) =
203        if v>=hi then trim_hi hi l else s
204
205    fun uni_hi s E hi = s
206      | uni_hi E (T(v,_,l,r)) hi =
207        concat3 l v (split_lt r hi)
208      | uni_hi (T(v,_,l1,r1)) (s2 as T(v2,_,l2,r2)) hi =
209        concat3 (uni_hi l1 (trim_hi v s2) v)
210                v
211                (uni_bd r1 (trim v hi s2) v hi)
212
213    fun uni_lo s E lo = s
214      | uni_lo E (T(v,_,l,r)) lo =
215        concat3 (split_gt l lo) v r
216      | uni_lo (T(v,_,l1,r1)) (s2 as T(v2,_,l2,r2)) lo =
217        concat3 (uni_bd l1 (trim lo v s2) lo v)
218                v
219                (uni_lo r1 (trim_lo v s2) v)
220
221    fun uni (s,E) = s
222      | uni (E,s as T(v,_,l,r)) = s
223      | uni (T(v,_,l1,r1), s2 as T(v2,_,l2,r2)) =
224        concat3 (uni_hi l1 (trim_hi v s2) v)
225                v
226                (uni_lo r1 (trim_lo v s2) v)
227in
228    val union = uni
229end
230
231fun addList (s,l) = List.foldl (fn (i,s) => addt s i) s l
232
233fun add(s, i) = addt s i
234
235fun difference (E,s)  = E
236  | difference (s,E)  = s
237  | difference (s, T(v,_,l,r)) =
238    let val l2 = split_lt s v
239        val r2 = split_gt s v
240    in
241        concat (difference(l2,l)) (difference(r2,r))
242    end
243
244fun membert set x =
245    let fun mem E = false
246          | mem (T(v,_,l,r)) =
247            if x<v then mem l else if x>v then mem r else true
248    in mem set end
249
250fun member (set,x) = membert set x
251
252(*fun intersection (a,b) = difference(a,difference(a,b))*)
253
254fun intersection (E,_) = E
255  | intersection (_,E) = E
256  | intersection (s, T(v,_,l,r)) =
257    let val l2 = split_lt s v
258        val r2 = split_gt s v
259    in
260        if membert s v then
261            concat3 (intersection(l2,l)) v (intersection(r2,r))
262        else
263            concat (intersection(l2,l)) (intersection(r2,r))
264    end
265
266fun numItems E = 0
267  | numItems (T(_,n,_,_)) = n
268
269fun isEmpty E = true
270  | isEmpty _ = false
271
272fun delete (E,x) = raise NotFound
273  | delete (set as T(v,_,l,r),x) =
274    if x<v then T'(v,delete(l,x),r)
275    else if x>v then T'(v,l,delete(r,x))
276    else delete'(l,r)
277
278fun foldr f base set =
279    let fun fold' base E = base
280          | fold' base (T(v,_,l,r)) = fold' (f(v, fold' base r)) l
281    in fold' base set end
282
283fun foldl f base set =
284    let fun fold' base E = base
285          | fold' base (T(v,_,l,r)) = fold' (f(v, fold' base l)) r
286    in fold' base set end
287
288fun app f set =
289    let fun app' E = ()
290          | app'(T(v,_,l,r)) = (app' l; f v; app' r)
291    in app' set end
292
293fun revapp f set =
294    let fun app' E = ()
295          | app'(T(v,_,l,r)) = (app' r; f v; app' l)
296    in app' set end
297
298local
299    (* true if every item in t is in t' *)
300    fun treeIn t t' =
301        let
302            fun isIn E = true
303              | isIn (T(v,_,E,E)) = membert t' v
304              | isIn (T(v,_,l,E)) =
305                membert t' v andalso isIn l
306              | isIn (T(v,_,E,r)) =
307                membert t' v andalso isIn r
308              | isIn (T(v,_,l,r)) =
309                membert t' v andalso isIn l andalso isIn r
310        in
311            isIn t
312        end
313in
314    fun isSubset (E,_) = true
315      | isSubset (_,E) = false
316      | isSubset (t as T(_,n,_,_),t' as T(_,n',_,_)) =
317        (n<=n') andalso treeIn t t'
318
319    fun equal (E,E) = true
320      | equal (t as T(_,n,_,_),t' as T(_,n',_,_)) =
321        (n=n') andalso treeIn t t'
322      | equal _ = false
323end
324
325fun find p set =
326    let fun h E            = NONE
327          | h (T(v,_,l,r)) =
328            if p v then SOME v
329            else case h l of
330                NONE => h r
331              | a => a
332    in h set end;
333
334fun listItems set = foldr (op::) [] set
335
336end
337