1signature Binarymap = 2sig 3(* Binarymap -- applicative maps as balanced ordered binary trees *) 4(* From SML/NJ lib 0.2, copyright 1993 by AT&T Bell Laboratories *) 5(* Original implementation due to Stephen Adams, Southampton, UK *) 6 7type ('key, 'a) dict 8 9exception NotFound 10 11val mkDict : ('key * 'key -> order) -> ('key, 'a) dict 12val insert : ('key, 'a) dict * 'key * 'a -> ('key, 'a) dict 13val find : ('key, 'a) dict * 'key -> 'a 14val peek : ('key, 'a) dict * 'key -> 'a option 15val remove : ('key, 'a) dict * 'key -> ('key, 'a) dict * 'a 16val numItems : ('key, 'a) dict -> int 17val listItems : ('key, 'a) dict -> ('key * 'a) list 18val app : ('key * 'a -> unit) -> ('key,'a) dict -> unit 19val revapp : ('key * 'a -> unit) -> ('key,'a) dict -> unit 20val foldr : ('key * 'a * 'b -> 'b)-> 'b -> ('key,'a) dict -> 'b 21val foldl : ('key * 'a * 'b -> 'b) -> 'b -> ('key,'a) dict -> 'b 22val map : ('key * 'a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict 23val transform : ('a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict 24 25(* 26 [('key, 'a) dict] is the type of applicative maps from domain type 27 'key to range type 'a, or equivalently, applicative dictionaries 28 with keys of type 'key and values of type 'a. They are implemented 29 as ordered balanced binary trees. 30 31 [mkDict ordr] returns a new, empty map whose keys have ordering 32 ordr. 33 34 [insert(m, i, v)] extends (or modifies) map m to map i to v. 35 36 [find (m, k)] returns v if m maps k to v; otherwise raises NotFound. 37 38 [peek(m, k)] returns SOME v if m maps k to v; otherwise returns NONE. 39 40 [remove(m, k)] removes k from the domain of m and returns the 41 modified map and the element v corresponding to k. Raises NotFound 42 if k is not in the domain of m. 43 44 [numItems m] returns the number of entries in m (that is, the size 45 of the domain of m). 46 47 [listItems m] returns a list of the entries (k, v) of keys k and 48 the corresponding values v in m, in order of increasing key values. 49 50 [app f m] applies function f to the entries (k, v) in m, in 51 increasing order of k (according to the ordering ordr used to 52 create the map or dictionary). 53 54 [revapp f m] applies function f to the entries (k, v) in m, in 55 decreasing order of k. 56 57 [foldl f e m] applies the folding function f to the entries (k, v) 58 in m, in increasing order of k. 59 60 [foldr f e m] applies the folding function f to the entries (k, v) 61 in m, in decreasing order of k. 62 63 [map f m] returns a new map whose entries have form (k, f(k,v)), 64 where (k, v) is an entry in m. 65 66 [transform f m] returns a new map whose entries have form (k, f v), 67 where (k, v) is an entry in m. 68*) 69end 70 71structure Binarymap :> Binarymap = 72struct 73(* Binarymap -- modified for Moscow ML 74 * from SML/NJ library v. 0.2 file binary-dict.sml. 75 * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. 76 * See file mosml/copyrght/copyrght.att for details. 77 * 78 * This code was adapted from Stephen Adams' binary tree implementation 79 * of applicative integer sets. 80 * 81 * Copyright 1992 Stephen Adams. 82 * 83 * This software may be used freely provided that: 84 * 1. This copyright notice is attached to any copy, derived work, 85 * or work including all or part of this software. 86 * 2. Any derived work must contain a prominent notice stating that 87 * it has been altered from the original. 88 * 89 * 90 * Name(s): Stephen Adams. 91 * Department, Institution: Electronics & Computer Science, 92 * University of Southampton 93 * Address: Electronics & Computer Science 94 * University of Southampton 95 * Southampton SO9 5NH 96 * Great Britian 97 * E-mail: sra@ecs.soton.ac.uk 98 * 99 * Comments: 100 * 101 * 1. The implementation is based on Binary search trees of Bounded 102 * Balance, similar to Nievergelt & Reingold, SIAM J. Computing 103 * 2(1), March 1973. The main advantage of these trees is that 104 * they keep the size of the tree in the node, giving a constant 105 * time size operation. 106 * 107 * 2. The bounded balance criterion is simpler than N&R's alpha. 108 * Simply, one subtree must not have more than `weight' times as 109 * many elements as the opposite subtree. Rebalancing is 110 * guaranteed to reinstate the criterion for weight>2.23, but 111 * the occasional incorrect behaviour for weight=2 is not 112 * detrimental to performance. 113 * 114 *) 115 116exception NotFound 117 118fun wt (i : int) = 3 * i 119 120datatype ('key, 'a) dict = 121 DICT of ('key * 'key -> order) * ('key, 'a) tree 122and ('key, 'a) tree = 123 E 124 | T of {key : 'key, 125 value : 'a, 126 cnt : int, 127 left : ('key, 'a) tree, 128 right : ('key, 'a) tree} 129 130fun treeSize E = 0 131 | treeSize (T{cnt,...}) = cnt 132 133fun numItems (DICT(_, t)) = treeSize t 134 135local 136 fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 137 | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} 138 | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} 139 | N(k,v,l as T n,r as T n') = 140 T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} 141 142 fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 143 N(b,bv,N(a,av,x,y),z) 144 | single_L _ = raise Match 145 fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 146 N(a,av,x,N(b,bv,y,z)) 147 | single_R _ = raise Match 148 fun double_L (a,av,w,T{key=c,value=cv, 149 left=T{key=b,value=bv,left=x,right=y,...}, 150 right=z,...}) = 151 N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 152 | double_L _ = raise Match 153 fun double_R (c,cv,T{key=a,value=av,left=w, 154 right=T{key=b,value=bv,left=x,right=y,...},...},z) = 155 N(b,bv,N(a,av,w,x),N(c,cv,y,z)) 156 | double_R _ = raise Match 157 158 fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} 159 | T' (k,v,E,r as T{right=E,left=E,...}) = 160 T{key=k,value=v,cnt=2,left=E,right=r} 161 | T' (k,v,l as T{right=E,left=E,...},E) = 162 T{key=k,value=v,cnt=2,left=l,right=E} 163 164 | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p 165 | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p 166 167 (* these cases almost never happen with small weight*) 168 | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = 169 if ln < rn then single_L p else double_L p 170 | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = 171 if ln > rn then single_R p else double_R p 172 173 | T' (p as (_,_,E,T{left=E,...})) = single_L p 174 | T' (p as (_,_,T{right=E,...},E)) = single_R p 175 176 | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, 177 r as T{cnt=rn,left=rl,right=rr,...})) = 178 if rn >= wt ln then (*right is too big*) 179 let val rln = treeSize rl 180 val rrn = treeSize rr 181 in 182 if rln < rrn then single_L p else double_L p 183 end 184 185 else if ln >= wt rn then (*left is too big*) 186 let val lln = treeSize ll 187 val lrn = treeSize lr 188 in 189 if lrn < lln then single_R p else double_R p 190 end 191 192 else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} 193 194 local 195 fun min (T{left=E,key,value,...}) = (key,value) 196 | min (T{left,...}) = min left 197 | min _ = raise Match 198 199 fun delmin (T{left=E,right,...}) = right 200 | delmin (T{key,value,left,right,...}) = 201 T'(key,value,delmin left,right) 202 | delmin _ = raise Match 203 in 204 fun delete' (E,r) = r 205 | delete' (l,E) = l 206 | delete' (l,r) = let val (mink,minv) = min r 207 in T'(mink,minv,l,delmin r) end 208 end 209in 210 fun mkDict cmpKey = DICT(cmpKey, E) 211 212 fun insert (DICT (cmpKey, t),x,v) = 213 let fun ins E = T{key=x,value=v,cnt=1,left=E,right=E} 214 | ins (T(set as {key,left,right,value,...})) = 215 case cmpKey (key,x) of 216 GREATER => T'(key,value,ins left,right) 217 | LESS => T'(key,value,left,ins right) 218 | _ => 219 T{key=x,value=v,left=left,right=right,cnt= #cnt set} 220 in DICT(cmpKey, ins t) end 221 222 fun find (DICT(cmpKey, t), x) = 223 let fun mem E = raise NotFound 224 | mem (T(n as {key,left,right,...})) = 225 case cmpKey (x,key) of 226 GREATER => mem right 227 | LESS => mem left 228 | _ => #value n 229 in mem t end 230 231 fun peek arg = (SOME(find arg)) handle NotFound => NONE 232 233 fun remove (DICT(cmpKey, t), x) = 234 let fun rm E = raise NotFound 235 | rm (set as T{key,left,right,value,...}) = 236 (case cmpKey (key,x) of 237 GREATER => let val (left', v) = rm left 238 in (T'(key, value, left', right), v) end 239 | LESS => let val (right', v) = rm right 240 in (T'(key, value, left, right'), v) end 241 | _ => (delete'(left,right),value)) 242 val (newtree, valrm) = rm t 243 in (DICT(cmpKey, newtree), valrm) end 244 245 fun listItems (DICT(_, d)) = 246 let fun d2l E res = res 247 | d2l (T{key,value,left,right,...}) res = 248 d2l left ((key,value) :: d2l right res) 249 in d2l d [] end 250 251 fun revapp f (DICT(_, d)) = let 252 fun a E = () 253 | a (T{key,value,left,right,...}) = (a right; f(key,value); a left) 254 in a d end 255 256 fun app f (DICT(_, d)) = let 257 fun a E = () 258 | a (T{key,value,left,right,...}) = (a left; f(key,value); a right) 259 in a d end 260 261 fun foldr f init (DICT(_, d)) = let 262 fun a E v = v 263 | a (T{key,value,left,right,...}) v = a left (f(key,value,a right v)) 264 in a d init end 265 266 fun foldl f init (DICT(_, d)) = let 267 fun a E v = v 268 | a (T{key,value,left,right,...}) v = a right (f(key,value,a left v)) 269 in a d init end 270 271 fun map f (DICT(cmpKey, d)) = let 272 fun a E = E 273 | a (T{key,value,left,right,cnt}) = let 274 val left' = a left 275 val value' = f(key,value) 276 in 277 T{cnt=cnt, key=key,value=value',left = left', right = a right} 278 end 279 in DICT(cmpKey, a d) end 280 281 fun transform f (DICT(cmpKey, d)) = 282 let fun a E = E 283 | a (T{key,value,left,right,cnt}) = 284 let val left' = a left 285 in 286 T{cnt=cnt, key=key, value=f value, left = left', 287 right = a right} 288 end 289 in DICT(cmpKey, a d) end 290end 291 292 293end 294