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