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