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