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