# SCM Repository

# View of /sml/branches/SMLNJ/src/smlnj-lib/Util/binary-map-fn.sml

Parent Directory | Revision Log

Revision

Original Path:

File size: 10947 byte(s)

**2**- (**download**) (**annotate**)*Sat Oct 4 23:33:09 1997 UTC*(22 years, 10 months ago) by*monnier*Original Path:

*sml/trunk/src/smlnj-lib/Util/binary-map-fn.sml*File size: 10947 byte(s)

Initial revision

(* binary-map-fn.sml * * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. * * This code was adapted from Stephen Adams' binary tree implementation * of applicative integer sets. * * Copyright 1992 Stephen Adams. * * This software may be used freely provided that: * 1. This copyright notice is attached to any copy, derived work, * or work including all or part of this software. * 2. Any derived work must contain a prominent notice stating that * it has been altered from the original. * * * Name(s): Stephen Adams. * Department, Institution: Electronics & Computer Science, * University of Southampton * Address: Electronics & Computer Science * University of Southampton * Southampton SO9 5NH * Great Britian * E-mail: sra@ecs.soton.ac.uk * * Comments: * * 1. The implementation is based on Binary search trees of Bounded * Balance, similar to Nievergelt & Reingold, SIAM J. Computing * 2(1), March 1973. The main advantage of these trees is that * they keep the size of the tree in the node, giving a constant * time size operation. * * 2. The bounded balance criterion is simpler than N&R's alpha. * Simply, one subtree must not have more than `weight' times as * many elements as the opposite subtree. Rebalancing is * guaranteed to reinstate the criterion for weight>2.23, but * the occasional incorrect behaviour for weight=2 is not * detrimental to performance. * *) functor BinaryMapFn (K : ORD_KEY) : ORD_MAP = struct structure Key = K (* ** val weight = 3 ** fun wt i = weight * i *) fun wt (i : int) = i + i + i datatype 'a map = E | T of { key : K.ord_key, value : 'a, cnt : int, left : 'a map, right : 'a map } val empty = E fun numItems E = 0 | numItems (T{cnt,...}) = cnt local fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} | N(k,v,l as T n,r as T n') = T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = N(b,bv,N(a,av,x,y),z) | single_L _ = raise Match fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = N(a,av,x,N(b,bv,y,z)) | single_R _ = raise Match fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) = N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | double_L _ = raise Match fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | double_R _ = raise Match fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | T' (k,v,E,r as T{right=E,left=E,...}) = T{key=k,value=v,cnt=2,left=E,right=r} | T' (k,v,l as T{right=E,left=E,...},E) = T{key=k,value=v,cnt=2,left=l,right=E} | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p (* these cases almost never happen with small weight*) | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = if ln < rn then single_L p else double_L p | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = if ln > rn then single_R p else double_R p | T' (p as (_,_,E,T{left=E,...})) = single_L p | T' (p as (_,_,T{right=E,...},E)) = single_R p | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, r as T{cnt=rn,left=rl,right=rr,...})) = if rn >= wt ln then (*right is too big*) let val rln = numItems rl val rrn = numItems rr in if rln < rrn then single_L p else double_L p end else if ln >= wt rn then (*left is too big*) let val lln = numItems ll val lrn = numItems lr in if lrn < lln then single_R p else double_R p end else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} local fun min (T{left=E,key,value,...}) = (key,value) | min (T{left,...}) = min left | min _ = raise Match fun delmin (T{left=E,right,...}) = right | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right) | delmin _ = raise Match in fun delete' (E,r) = r | delete' (l,E) = l | delete' (l,r) = let val (mink,minv) = min r in T'(mink,minv,l,delmin r) end end in fun mkDict () = E fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E} | insert (T(set as {key,left,right,value,...}),x,v) = case K.compare (key,x) of GREATER => T'(key,value,insert(left,x,v),right) | LESS => T'(key,value,left,insert(right,x,v)) | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set} fun find (set, x) = let fun mem E = NONE | mem (T(n as {key,left,right,...})) = (case K.compare (x,key) of GREATER => mem right | EQUAL => SOME(#value n) | LESS => mem left (* end case *)) in mem set end fun remove (E,x) = raise LibBase.NotFound | remove (set as T{key,left,right,value,...},x) = ( case K.compare (key,x) of GREATER => let val (left', v) = remove(left, x) in (T'(key, value, left', right), v) end | LESS => let val (right', v) = remove (right, x) in (T'(key, value, left, right'), v) end | _ => (delete'(left,right),value) (* end case *)) fun listItems d = let fun d2l (E, l) = l | d2l (T{key,value,left,right,...}, l) = d2l(left, value::(d2l(right,l))) in d2l (d,[]) end fun listItemsi d = let fun d2l (E, l) = l | d2l (T{key,value,left,right,...}, l) = d2l(left, (key,value)::(d2l(right,l))) in d2l (d,[]) end local fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) | next _ = (E, []) and left (E, rest) = rest | left (t as T{left=l, ...}, rest) = left(l, t::rest) in fun collate cmpRng (s1, s2) = let fun cmp (t1, t2) = (case (next t1, next t2) of ((E, _), (E, _)) => EQUAL | ((E, _), _) => LESS | (_, (E, _)) => GREATER | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => ( case Key.compare(x1, x2) of EQUAL => (case cmpRng(y1, y2) of EQUAL => cmp (r1, r2) | order => order (* end case *)) | order => order (* end case *)) (* end case *)) in cmp (left(s1, []), left(s2, [])) end end (* local *) fun appi f d = let fun app' E = () | app' (T{key,value,left,right,...}) = ( app' left; f(key, value); app' right) in app' d end fun app f d = let fun app' E = () | app' (T{value,left,right,...}) = ( app' left; f value; app' right) in app' d end fun mapi f d = let fun map' E = E | map' (T{key,value,left,right,cnt}) = let val left' = map' left val value' = f(key, value) val right' = map' right in T{cnt=cnt, key=key, value=value', left = left', right = right'} end in map' d end fun map f d = mapi (fn (_, x) => f x) d fun foldli f init d = let fun fold (E, v) = v | fold (T{key,value,left,right,...}, v) = fold (right, f(key, value, fold(left, v))) in fold (d, init) end fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d fun foldri f init d = let fun fold (E,v) = v | fold (T{key,value,left,right,...},v) = fold (left, f(key, value, fold(right, v))) in fold (d, init) end fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d (** To be implemented ** val filter : ('a -> bool) -> 'a map -> 'a map val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map **) end (* local *) (* the following are generic implementations of the unionWith and intersectWith * operetions. These should be specialized for the internal representations * at some point. *) fun unionWith f (m1, m2) = let fun ins f (key, x, m) = (case find(m, key) of NONE => insert(m, key, x) | (SOME x') => insert(m, key, f(x, x')) (* end case *)) in if (numItems m1 > numItems m2) then foldli (ins (fn (a, b) => f (b, a))) m1 m2 else foldli (ins f) m2 m1 end fun unionWithi f (m1, m2) = let fun ins f (key, x, m) = (case find(m, key) of NONE => insert(m, key, x) | (SOME x') => insert(m, key, f(key, x, x')) (* end case *)) in if (numItems m1 > numItems m2) then foldli (ins (fn (k, a, b) => f (k, b, a))) m1 m2 else foldli (ins f) m2 m1 end fun intersectWith f (m1, m2) = let (* iterate over the elements of m1, checking for membership in m2 *) fun intersect f (m1, m2) = let fun ins (key, x, m) = (case find(m2, key) of NONE => m | (SOME x') => insert(m, key, f(x, x')) (* end case *)) in foldli ins empty m1 end in if (numItems m1 > numItems m2) then intersect f (m1, m2) else intersect (fn (a, b) => f(b, a)) (m2, m1) end fun intersectWithi f (m1, m2) = let (* iterate over the elements of m1, checking for membership in m2 *) fun intersect f (m1, m2) = let fun ins (key, x, m) = (case find(m2, key) of NONE => m | (SOME x') => insert(m, key, f(key, x, x')) (* end case *)) in foldli ins empty m1 end in if (numItems m1 > numItems m2) then intersect f (m1, m2) else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1) end (* this is a generic implementation of filter. It should * be specialized to the data-structure at some point. *) fun filter predFn m = let fun f (key, item, m) = if predFn item then insert(m, key, item) else m in foldli f empty m end fun filteri predFn m = let fun f (key, item, m) = if predFn(key, item) then insert(m, key, item) else m in foldli f empty m end (* this is a generic implementation of mapPartial. It should * be specialized to the data-structure at some point. *) fun mapPartial f m = let fun g (key, item, m) = (case f item of NONE => m | (SOME item') => insert(m, key, item') (* end case *)) in foldli g empty m end fun mapPartiali f m = let fun g (key, item, m) = (case f(key, item) of NONE => m | (SOME item') => insert(m, key, item') (* end case *)) in foldli g empty m end end (* functor BinaryMapFn *)

root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |

Powered by ViewVC 1.0.0 |