1(* 2 * extended by functions: 3 * update, findSome 4 *) 5 6(* int-binary-map.sml 7 * 8 * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. 9 * 10 * This code was adapted from Stephen Adams' binary tree implementation 11 * of applicative integer sets. 12 * 13 * Copyright 1992 Stephen Adams. 14 * 15 * This software may be used freely provided that: 16 * 1. This copyright notice is attached to any copy, derived work, 17 * or work including all or part of this software. 18 * 2. Any derived work must contain a prominent notice stating that 19 * it has been altered from the original. 20 * 21 * 22 * Name(s): Stephen Adams. 23 * Department, Institution: Electronics & Computer Science, 24 * University of Southampton 25 * Address: Electronics & Computer Science 26 * University of Southampton 27 * Southampton SO9 5NH 28 * Great Britian 29 * E-mail: sra@ecs.soton.ac.uk 30 * 31 * Comments: 32 * 33 * 1. The implementation is based on Binary search trees of Bounded 34 * Balance, similar to Nievergelt & Reingold, SIAM J. Computing 35 * 2(1), March 1973. The main advantage of these trees is that 36 * they keep the size of the tree in the node, giving a constant 37 * time size operation. 38 * 39 * 2. The bounded balance criterion is simpler than N&R's alpha. 40 * Simply, one subtree must not have more than `weight' times as 41 * many elements as the opposite subtree. Rebalancing is 42 * guaranteed to reinstate the criterion for weight>2.23, but 43 * the occasional incorrect behaviour for weight=2 is not 44 * detrimental to performance. 45 * 46 * Altered to work as a geneal intmap - Emden Gansner 47 * 48 * Extended by two functions "update" and "findSome" - Martin Erwig 49 *) 50 51structure IntBinaryMapUpd : ORD_MAP_UPD = 52 struct 53 54 structure Key = 55 struct 56 type ord_key = int 57 val compare = Int.compare 58 end 59 60 (* 61 ** val weight = 3 62 ** fun wt i = weight * i 63 *) 64 fun wt (i : int) = i + i + i 65 66 datatype 'a map 67 = E 68 | T of { 69 key : int, 70 value : 'a, 71 cnt : int, 72 left : 'a map, 73 right : 'a map 74 } 75 76 fun numItems E = 0 77 | numItems (T{cnt,...}) = cnt 78 79local 80 fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 81 | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} 82 | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} 83 | N(k,v,l as T n,r as T n') = 84 T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} 85 86 fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 87 N(b,bv,N(a,av,x,y),z) 88 | single_L _ = raise Match 89 fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 90 N(a,av,x,N(b,bv,y,z)) 91 | single_R _ = raise Match 92 fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) = 93 N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 94 | double_L _ = raise Match 95 fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = 96 N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 97 | double_R _ = raise Match 98 99 fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 100 | T' (k,v,E,r as T{right=E,left=E,...}) = 101 T{key=k,value=v,cnt=2,left=E,right=r} 102 | T' (k,v,l as T{right=E,left=E,...},E) = 103 T{key=k,value=v,cnt=2,left=l,right=E} 104 105 | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p 106 | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p 107 108 (* these cases almost never happen with small weight*) 109 | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = 110 if ln < rn then single_L p else double_L p 111 | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = 112 if ln > rn then single_R p else double_R p 113 114 | T' (p as (_,_,E,T{left=E,...})) = single_L p 115 | T' (p as (_,_,T{right=E,...},E)) = single_R p 116 117 | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, 118 r as T{cnt=rn,left=rl,right=rr,...})) = 119 if rn >= wt ln then (*right is too big*) 120 let val rln = numItems rl 121 val rrn = numItems rr 122 in 123 if rln < rrn then single_L p else double_L p 124 end 125 126 else if ln >= wt rn then (*left is too big*) 127 let val lln = numItems ll 128 val lrn = numItems lr 129 in 130 if lrn < lln then single_R p else double_R p 131 end 132 133 else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} 134 135 local 136 fun min (T{left=E,key,value,...}) = (key,value) 137 | min (T{left,...}) = min left 138 | min _ = raise Match 139 140 fun delmin (T{left=E,right,...}) = right 141 | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right) 142 | delmin _ = raise Match 143 in 144 fun delete' (E,r) = r 145 | delete' (l,E) = l 146 | delete' (l,r) = let val (mink,minv) = min r in 147 T'(mink,minv,l,delmin r) 148 end 149 end 150in 151 val empty = E 152 153 fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E} 154 | insert (T(set as {key,left,right,value,...}),x,v) = 155 if key > x then T'(key,value,insert(left,x,v),right) 156 else if key < x then T'(key,value,left,insert(right,x,v)) 157 else T{key=x,value=v,left=left,right=right,cnt= #cnt set} 158 159 fun update (E,_,_) = raise Binaryset.NotFound 160 | update (T(set as {key,left,right,value,...}),x,f) = 161 if key > x then T'(key,value,update(left,x,f),right) 162 else if key < x then T'(key,value,left,update(right,x,f)) 163 else T{key=x,value=f(value),left=left,right=right,cnt= #cnt set} 164 165 fun find (set, x) = let 166 fun mem E = NONE 167 | mem (T(n as {key,left,right,...})) = 168 if x > key then mem right 169 else if x < key then mem left 170 else SOME(#value n) 171 in 172 mem set 173 end 174 175 fun findSome E = NONE 176 | findSome (T{key,value,...}) = SOME (key,value) 177 178 fun remove (E,x) = raise Binaryset.NotFound 179 | remove (set as T{key,left,right,value,...},x) = 180 if key > x then 181 let val (left',v) = remove(left,x) 182 in (T'(key,value,left',right),v) end 183 else if key < x then 184 let val (right',v) = remove(right,x) 185 in (T'(key,value,left,right'),v) end 186 else (delete'(left,right),value) 187 188 fun listItems d = let 189 fun d2l (E, l) = l 190 | d2l (T{key,value,left,right,...}, l) = 191 d2l(left, value::(d2l(right,l))) 192 in 193 d2l (d,[]) 194 end 195 196 fun listItemsi d = let 197 fun d2l (E, l) = l 198 | d2l (T{key,value,left,right,...}, l) = 199 d2l(left, (key,value)::(d2l(right,l))) 200 in 201 d2l (d,[]) 202 end 203 204 local 205 fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) 206 | next _ = (E, []) 207 and left (E, rest) = rest 208 | left (t as T{left=l, ...}, rest) = left(l, t::rest) 209 in 210 fun collate cmpRng (s1, s2) = let 211 fun cmp (t1, t2) = (case (next t1, next t2) 212 of ((E, _), (E, _)) => EQUAL 213 | ((E, _), _) => LESS 214 | (_, (E, _)) => GREATER 215 | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => ( 216 case Key.compare(x1, x2) 217 of EQUAL => (case cmpRng(y1, y2) 218 of EQUAL => cmp (r1, r2) 219 | order => order 220 (* end case *)) 221 | order => order 222 (* end case *)) 223 (* end case *)) 224 in 225 cmp (left(s1, []), left(s2, [])) 226 end 227 end (* local *) 228 229 fun appi f d = let 230 fun appf E = () 231 | appf (T{key,value,left,right,...}) = ( 232 appf left; f(key,value); appf right) 233 in 234 appf d 235 end 236 fun app f d = appi (fn (_, v) => f v) d 237 238 fun mapi f d = let 239 fun mapf E = E 240 | mapf (T{key,value,left,right,cnt}) = let 241 val left' = mapf left 242 val value' = f(key, value) 243 val right' = mapf right 244 in 245 T{cnt=cnt, key=key, value=value', left = left', right = right'} 246 end 247 in 248 mapf d 249 end 250 fun map f d = mapi (fn (_, x) => f x) d 251 252 fun foldli f init d = let 253 fun fold (E,v) = v 254 | fold (T{key,value,left,right,...},v) = 255 fold (right, f(key, value, fold(left, v))) 256 in 257 fold (d, init) 258 end 259 fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d 260 261 fun foldri f init d = let 262 fun fold (E,v) = v 263 | fold (T{key,value,left,right,...},v) = 264 fold (left, f(key, value, fold(right, v))) 265 in 266 fold (d, init) 267 end 268 fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d 269 270 end (* local *) 271 272(* the following are generic implementations of the unionWith and intersectWith 273 * operetions. These should be specialized for the internal representations 274 * at some point. 275 *) 276 fun unionWith f (m1, m2) = let 277 fun ins (key, x, m) = (case find(m, key) 278 of NONE => insert(m, key, x) 279 | (SOME x') => insert(m, key, f(x, x')) 280 (* end case *)) 281 in 282 if (numItems m1 > numItems m2) 283 then foldli ins m1 m2 284 else foldli ins m2 m1 285 end 286 fun unionWithi f (m1, m2) = let 287 fun ins (key, x, m) = (case find(m, key) 288 of NONE => insert(m, key, x) 289 | (SOME x') => insert(m, key, f(key, x, x')) 290 (* end case *)) 291 in 292 if (numItems m1 > numItems m2) 293 then foldli ins m1 m2 294 else foldli ins m2 m1 295 end 296 297 fun intersectWith f (m1, m2) = let 298 (* iterate over the elements of m1, checking for membership in m2 *) 299 fun intersect (m1, m2) = let 300 fun ins (key, x, m) = (case find(m2, key) 301 of NONE => m 302 | (SOME x') => insert(m, key, f(x, x')) 303 (* end case *)) 304 in 305 foldli ins empty m1 306 end 307 in 308 if (numItems m1 > numItems m2) 309 then intersect (m1, m2) 310 else intersect (m2, m1) 311 end 312 313 fun intersectWithi f (m1, m2) = let 314 (* iterate over the elements of m1, checking for membership in m2 *) 315 fun intersect (m1, m2) = let 316 fun ins (key, x, m) = (case find(m2, key) 317 of NONE => m 318 | (SOME x') => insert(m, key, f(key, x, x')) 319 (* end case *)) 320 in 321 foldli ins empty m1 322 end 323 in 324 if (numItems m1 > numItems m2) 325 then intersect (m1, m2) 326 else intersect (m2, m1) 327 end 328 329 (* this is a generic implementation of filter. It should 330 * be specialized to the data-structure at some point. 331 *) 332 fun filter predFn m = let 333 fun f (key, item, m) = if predFn item 334 then insert(m, key, item) 335 else m 336 in 337 foldli f empty m 338 end 339 fun filteri predFn m = let 340 fun f (key, item, m) = if predFn(key, item) 341 then insert(m, key, item) 342 else m 343 in 344 foldli f empty m 345 end 346 347 (* this is a generic implementation of mapPartial. It should 348 * be specialized to the data-structure at some point. 349 *) 350 fun mapPartial f m = let 351 fun g (key, item, m) = (case f item 352 of NONE => m 353 | (SOME item') => insert(m, key, item') 354 (* end case *)) 355 in 356 foldli g empty m 357 end 358 fun mapPartiali f m = let 359 fun g (key, item, m) = (case f(key, item) 360 of NONE => m 361 | (SOME item') => insert(m, key, item') 362 (* end case *)) 363 in 364 foldli g empty m 365 end 366 367 end 368