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 *)