198184Sgordon(* 278344Sobrien * extended by functions: 3156813Sru * update, findSome 4156813Sru *) 5228541Spjd 6228541Spjd(* int-binary-map.sml 7228541Spjd * 8228541Spjd * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. 9228541Spjd * 10228541Spjd * This code was adapted from Stephen Adams' binary tree implementation 11228541Spjd * of applicative integer sets. 12228541Spjd * 13228541Spjd * Copyright 1992 Stephen Adams. 14228541Spjd * 15228541Spjd * This software may be used freely provided that: 16228541Spjd * 1. This copyright notice is attached to any copy, derived work, 17228541Spjd * or work including all or part of this software. 18243752Srwatson * 2. Any derived work must contain a prominent notice stating that 19228541Spjd * it has been altered from the original. 20256022Sgjb * 21228541Spjd * 22256022Sgjb * Name(s): Stephen Adams. 23228541Spjd * Department, Institution: Electronics & Computer Science, 24228541Spjd * University of Southampton 25228541Spjd * Address: Electronics & Computer Science 26255570Strasz * University of Southampton 27228541Spjd * Southampton SO9 5NH 28228541Spjd * Great Britian 29228541Spjd * E-mail: sra@ecs.soton.ac.uk 30228541Spjd * 31228541Spjd * Comments: 32228541Spjd * 33228541Spjd * 1. The implementation is based on Binary search trees of Bounded 34228541Spjd * Balance, similar to Nievergelt & Reingold, SIAM J. Computing 35228541Spjd * 2(1), March 1973. The main advantage of these trees is that 36228541Spjd * they keep the size of the tree in the node, giving a constant 37228541Spjd * time size operation. 38228541Spjd * 39228541Spjd * 2. The bounded balance criterion is simpler than N&R's alpha. 40284009Scperciva * Simply, one subtree must not have more than `weight' times as 41228541Spjd * many elements as the opposite subtree. Rebalancing is 42256022Sgjb * guaranteed to reinstate the criterion for weight>2.23, but 43228541Spjd * the occasional incorrect behaviour for weight=2 is not 44228541Spjd * detrimental to performance. 45228541Spjd * 46228541Spjd * Altered to work as a geneal intmap - Emden Gansner 47228541Spjd * 48228541Spjd * Extended by two functions "update" and "findSome" - Martin Erwig 49228541Spjd *) 50228541Spjd 51228541Spjdstructure IntBinaryMapUpd : ORD_MAP_UPD = 52228541Spjd struct 53228541Spjd 54228541Spjd structure Key = 55273286Shrs struct 56273286Shrs type ord_key = int 57273286Shrs val compare = Int.compare 58228541Spjd end 59228541Spjd 60273286Shrs (* 61228541Spjd ** val weight = 3 62228541Spjd ** fun wt i = weight * i 63228541Spjd *) 64228541Spjd fun wt (i : int) = i + i + i 65228541Spjd 66228541Spjd datatype 'a map 67228541Spjd = E 68228541Spjd | T of { 69228541Spjd key : int, 70228541Spjd value : 'a, 71228541Spjd cnt : int, 72228541Spjd left : 'a map, 73228541Spjd right : 'a map 74228541Spjd } 75228541Spjd 76228541Spjd fun numItems E = 0 77228541Spjd | numItems (T{cnt,...}) = cnt 78228541Spjd 79228541Spjdlocal 80228541Spjd fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 81228541Spjd | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} 82228541Spjd | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} 83228541Spjd | N(k,v,l as T n,r as T n') = 84228541Spjd T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} 85228541Spjd 86228541Spjd fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 87228541Spjd N(b,bv,N(a,av,x,y),z) 88228541Spjd | single_L _ = raise Match 89228541Spjd fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 90228541Spjd N(a,av,x,N(b,bv,y,z)) 91228541Spjd | single_R _ = raise Match 92228541Spjd fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) = 93240334Sobrien N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 94228541Spjd | double_L _ = raise Match 95228541Spjd fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = 96228541Spjd N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 97118224Smtm | double_R _ = raise Match 98228541Spjd 99228541Spjd fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 100228541Spjd | T' (k,v,E,r as T{right=E,left=E,...}) = 101228541Spjd T{key=k,value=v,cnt=2,left=E,right=r} 102228541Spjd | T' (k,v,l as T{right=E,left=E,...},E) = 103228541Spjd T{key=k,value=v,cnt=2,left=l,right=E} 104228541Spjd 105228541Spjd | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p 106228541Spjd | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p 107228541Spjd 108228541Spjd (* these cases almost never happen with small weight*) 109228541Spjd | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = 110228541Spjd if ln < rn then single_L p else double_L p 111228541Spjd | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = 112228541Spjd if ln > rn then single_R p else double_R p 113228541Spjd 114228541Spjd | T' (p as (_,_,E,T{left=E,...})) = single_L p 115228541Spjd | T' (p as (_,_,T{right=E,...},E)) = single_R p 116228541Spjd 117228541Spjd | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, 118228541Spjd r as T{cnt=rn,left=rl,right=rr,...})) = 119252310Shrs if rn >= wt ln then (*right is too big*) 120252310Shrs let val rln = numItems rl 121228541Spjd val rrn = numItems rr 122228541Spjd in 123228541Spjd if rln < rrn then single_L p else double_L p 124228541Spjd end 125153430Siedowse 126255809Sdes else if ln >= wt rn then (*left is too big*) 127231534Sed let val lln = numItems ll 128228541Spjd val lrn = numItems lr 129228541Spjd in 130228541Spjd if lrn < lln then single_R p else double_R p 131228541Spjd end 132228541Spjd 133228541Spjd else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} 134228541Spjd 135228541Spjd local 136228541Spjd fun min (T{left=E,key,value,...}) = (key,value) 137150490Swollman | min (T{left,...}) = min left 138278574Sngie | min _ = raise Match 139278574Sngie 140278574Sngie fun delmin (T{left=E,right,...}) = right 141278574Sngie | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right) 142278246Sngie | delmin _ = raise Match 143278246Sngie in 144278246Sngie fun delete' (E,r) = r 145278246Sngie | delete' (l,E) = l 146280422Sngie | delete' (l,r) = let val (mink,minv) = min r in 147280422Sngie T'(mink,minv,l,delmin r) 148280422Sngie end 149280422Sngie end 150278191Sngiein 151278191Sngie val empty = E 152278191Sngie 153278191Sngie fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E} 154278190Sngie | insert (T(set as {key,left,right,value,...}),x,v) = 155278190Sngie if key > x then T'(key,value,insert(left,x,v),right) 156278190Sngie else if key < x then T'(key,value,left,insert(right,x,v)) 157278190Sngie else T{key=x,value=v,left=left,right=right,cnt= #cnt set} 158278190Sngie 159278558Sngie fun update (E,_,_) = raise Binaryset.NotFound 160278558Sngie | update (T(set as {key,left,right,value,...}),x,f) = 161278558Sngie if key > x then T'(key,value,update(left,x,f),right) 162278558Sngie else if key < x then T'(key,value,left,update(right,x,f)) 163278558Sngie else T{key=x,value=f(value),left=left,right=right,cnt= #cnt set} 164278558Sngie 165278052Sngie fun find (set, x) = let 166278052Sngie fun mem E = NONE 167278052Sngie | mem (T(n as {key,left,right,...})) = 168278052Sngie if x > key then mem right 169278052Sngie else if x < key then mem left 170278052Sngie else SOME(#value n) 171278052Sngie in 172280422Sngie mem set 173280422Sngie end 174280422Sngie 175280422Sngie fun findSome E = NONE 176278068Sngie | findSome (T{key,value,...}) = SOME (key,value) 177278068Sngie 178278068Sngie fun remove (E,x) = raise Binaryset.NotFound 179278068Sngie | remove (set as T{key,left,right,value,...},x) = 180278717Sngie if key > x then 181278717Sngie let val (left',v) = remove(left,x) 182225120Sdelphij in (T'(key,value,left',right),v) end 183225120Sdelphij else if key < x then 184280422Sngie let val (right',v) = remove(right,x) 185280422Sngie in (T'(key,value,left,right'),v) end 186280422Sngie else (delete'(left,right),value) 187280422Sngie 188278556Sngie fun listItems d = let 189278556Sngie fun d2l (E, l) = l 190278556Sngie | d2l (T{key,value,left,right,...}, l) = 191278556Sngie d2l(left, value::(d2l(right,l))) 192278717Sngie in 193278717Sngie d2l (d,[]) 194278717Sngie end 195278717Sngie 196280422Sngie fun listItemsi d = let 197280422Sngie fun d2l (E, l) = l 198280422Sngie | d2l (T{key,value,left,right,...}, l) = 199280422Sngie d2l(left, (key,value)::(d2l(right,l))) 200278555Sngie in 201278555Sngie d2l (d,[]) 202278555Sngie end 203278555Sngie 204278555Sngie local 205278185Sngie fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) 206278185Sngie | next _ = (E, []) 207278185Sngie and left (E, rest) = rest 208278185Sngie | left (t as T{left=l, ...}, rest) = left(l, t::rest) 209273286Shrs in 210278570Sngie fun collate cmpRng (s1, s2) = let 211278570Sngie fun cmp (t1, t2) = (case (next t1, next t2) 212273286Shrs of ((E, _), (E, _)) => EQUAL 213273286Shrs | ((E, _), _) => LESS 214273286Shrs | (_, (E, _)) => GREATER 215273286Shrs | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => ( 216273286Shrs case Key.compare(x1, x2) 217273286Shrs of EQUAL => (case cmpRng(y1, y2) 218280422Sngie of EQUAL => cmp (r1, r2) 219280422Sngie | order => order 220280422Sngie (* end case *)) 221280422Sngie | order => order 222280422Sngie (* end case *)) 223278188Sngie (* end case *)) 224278188Sngie in 225278188Sngie cmp (left(s1, []), left(s2, [])) 226278188Sngie end 227280422Sngie end (* local *) 228280422Sngie 229280422Sngie fun appi f d = let 230280422Sngie fun appf E = () 231278052Sngie | appf (T{key,value,left,right,...}) = ( 232278052Sngie appf left; f(key,value); appf right) 233278052Sngie in 234278052Sngie appf d 235280422Sngie end 236280422Sngie fun app f d = appi (fn (_, v) => f v) d 237280422Sngie 238280422Sngie fun mapi f d = let 239219820Sjeff fun mapf E = E 240228541Spjd | mapf (T{key,value,left,right,cnt}) = let 241219820Sjeff val left' = mapf left 242219820Sjeff val value' = f(key, value) 243280422Sngie val right' = mapf right 244280422Sngie in 245280422Sngie T{cnt=cnt, key=key, value=value', left = left', right = right'} 246280422Sngie end 247156813Sru in 248228541Spjd mapf d 249150490Swollman end 250150490Swollman fun map f d = mapi (fn (_, x) => f x) d 251280422Sngie 252280422Sngie fun foldli f init d = let 253280422Sngie fun fold (E,v) = v 254280422Sngie | fold (T{key,value,left,right,...},v) = 255280422Sngie fold (right, f(key, value, fold(left, v))) 256280422Sngie in 257280422Sngie fold (d, init) 258280422Sngie end 259280422Sngie fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d 260280422Sngie 261280422Sngie fun foldri f init d = let 262280422Sngie fun fold (E,v) = v 263280422Sngie | fold (T{key,value,left,right,...},v) = 264280422Sngie fold (left, f(key, value, fold(right, v))) 265280422Sngie in 266280422Sngie fold (d, init) 267280422Sngie end 268280422Sngie fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d 269280422Sngie 270280422Sngie end (* local *) 271255809Sdes 272255809Sdes(* the following are generic implementations of the unionWith and intersectWith 273255809Sdes * operetions. These should be specialized for the internal representations 274255809Sdes * at some point. 275231534Sed *) 276231534Sed fun unionWith f (m1, m2) = let 277231534Sed fun ins (key, x, m) = (case find(m, key) 278231534Sed of NONE => insert(m, key, x) 279278242Sngie | (SOME x') => insert(m, key, f(x, x')) 280278242Sngie (* end case *)) 281278242Sngie in 282278242Sngie if (numItems m1 > numItems m2) 283278242Sngie then foldli ins m1 m2 284301612Sngie else foldli ins m2 m1 285301612Sngie end 286308244Savg fun unionWithi f (m1, m2) = let 287301612Sngie fun ins (key, x, m) = (case find(m, key) 288301612Sngie of NONE => insert(m, key, x) 289301612Sngie | (SOME x') => insert(m, key, f(key, x, x')) 29078344Sobrien (* end case *)) 29178344Sobrien in 29278344Sobrien if (numItems m1 > numItems m2) 29378344Sobrien 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