3 * COPYRIGHT (c
) 1993 by AT
&T Bell Laboratories
. See COPYRIGHT file for details
.
5 * This code was adapted from Stephen Adams
' binary tree implementation
6 * of applicative integer sets
.
8 * Copyright
1992 Stephen Adams
.
10 * This software may be used freely provided that
:
11 * 1. This copyright notice is attached to any copy
, derived work
,
12 * or work including all or part
of this software
.
13 * 2. Any derived work must contain a prominent notice stating that
14 * it has been altered from the original
.
17 * Name(s
): Stephen Adams
.
18 * Department
, Institution
: Electronics
& Computer Science
,
19 * University
of Southampton
20 * Address
: Electronics
& Computer Science
21 * University
of Southampton
24 * E
-mail
: sra@ecs
.soton
.ac
.uk
28 * 1. The implementation is based on Binary search trees
of Bounded
29 * Balance
, similar to Nievergelt
& Reingold
, SIAM J
. Computing
30 * 2(1), March
1973. The main advantage
of these trees is that
31 * they keep the size
of the tree
in the node
, giving a constant
32 * time size operation
.
34 * 2. The bounded balance criterion is simpler than N
&R
's alpha
.
35 * Simply
, one subtree must not have more than `weight
' times
as
36 * many elements
as the opposite subtree
. Rebalancing is
37 * guaranteed to reinstate the criterion for weight
>2.23, but
38 * the occasional incorrect behaviour for weight
=2 is not
39 * detrimental to performance
.
43 functor BinaryMapFn (K
: ORD_KEY
) : ORD_MAP
=
50 ** fun wt i
= weight
* i
52 fun wt (i
: int) = i
+ i
+ i
70 |
numItems (T
{cnt
,...}) = cnt
72 (* return the first item
in the
map (or NONE
if it is empty
) *)
74 |
first (T
{value
, left
=E
, ...}) = SOME value
75 |
first (T
{left
, ...}) = first left
77 (* return the first item
in the map
and its
key (or NONE
if it is empty
) *)
79 |
firsti (T
{key
, value
, left
=E
, ...}) = SOME(key
, value
)
80 |
firsti (T
{left
, ...}) = firsti left
83 fun N(k
,v
,E
,E
) = T
{key
=k
,value
=v
,cnt
=1,left
=E
,right
=E
}
84 |
N(k
,v
,E
,r
as T n
) = T
{key
=k
,value
=v
,cnt
=1+(#cnt n
),left
=E
,right
=r
}
85 |
N(k
,v
,l
as T n
,E
) = T
{key
=k
,value
=v
,cnt
=1+(#cnt n
),left
=l
,right
=E
}
86 |
N(k
,v
,l
as T n
,r
as T n
') =
87 T
{key
=k
,value
=v
,cnt
=1+(#cnt n
)+(#cnt n
'),left
=l
,right
=r
}
89 fun single_L (a
,av
,x
,T
{key
=b
,value
=bv
,left
=y
,right
=z
,...}) =
91 | single_L _
= raise Match
92 fun single_R (b
,bv
,T
{key
=a
,value
=av
,left
=x
,right
=y
,...},z
) =
94 | single_R _
= raise Match
95 fun double_L (a
,av
,w
,T
{key
=c
,value
=cv
,left
=T
{key
=b
,value
=bv
,left
=x
,right
=y
,...},right
=z
,...}) =
96 N(b
,bv
,N(a
,av
,w
,x
),N(c
,cv
,y
,z
))
97 | double_L _
= raise Match
98 fun double_R (c
,cv
,T
{key
=a
,value
=av
,left
=w
,right
=T
{key
=b
,value
=bv
,left
=x
,right
=y
,...},...},z
) =
99 N(b
,bv
,N(a
,av
,w
,x
),N(c
,cv
,y
,z
))
100 | double_R _
= raise Match
102 fun T
' (k
,v
,E
,E
) = T
{key
=k
,value
=v
,cnt
=1,left
=E
,right
=E
}
103 | T
' (k
,v
,E
,r
as T
{right
=E
,left
=E
,...}) =
104 T
{key
=k
,value
=v
,cnt
=2,left
=E
,right
=r
}
105 | T
' (k
,v
,l
as T
{right
=E
,left
=E
,...},E
) =
106 T
{key
=k
,value
=v
,cnt
=2,left
=l
,right
=E
}
108 | T
' (p
as (_
,_
,E
,T
{left
=T _
,right
=E
,...})) = double_L p
109 | T
' (p
as (_
,_
,T
{left
=E
,right
=T _
,...},E
)) = double_R p
111 (* these cases almost never happen
with small weight
*)
112 | T
' (p
as (_
,_
,E
,T
{left
=T
{cnt
=ln
,...},right
=T
{cnt
=rn
,...},...})) =
113 if ln
< rn
then single_L p
else double_L p
114 | T
' (p
as (_
,_
,T
{left
=T
{cnt
=ln
,...},right
=T
{cnt
=rn
,...},...},E
)) =
115 if ln
> rn
then single_R p
else double_R p
117 | T
' (p
as (_
,_
,E
,T
{left
=E
,...})) = single_L p
118 | T
' (p
as (_
,_
,T
{right
=E
,...},E
)) = single_R p
120 | T
' (p
as (k
,v
,l
as T
{cnt
=ln
,left
=ll
,right
=lr
,...},
121 r
as T
{cnt
=rn
,left
=rl
,right
=rr
,...})) =
122 if rn
>= wt ln
then (*right is too big
*)
123 let val rln
= numItems rl
124 val rrn
= numItems rr
126 if rln
< rrn
then single_L p
else double_L p
129 else if ln
>= wt rn
then (*left is too big
*)
130 let val lln
= numItems ll
131 val lrn
= numItems lr
133 if lrn
< lln
then single_R p
else double_R p
136 else T
{key
=k
,value
=v
,cnt
=ln
+rn
+1,left
=l
,right
=r
}
139 fun min (T
{left
=E
,key
,value
,...}) = (key
,value
)
140 |
min (T
{left
,...}) = min left
141 | min _
= raise Match
143 fun delmin (T
{left
=E
,right
,...}) = right
144 |
delmin (T
{key
,value
,left
,right
,...}) = T
'(key
,value
,delmin left
,right
)
145 | delmin _
= raise Match
147 fun delete
' (E
,r
) = r
149 | delete
' (l
,r
) = let val (mink
,minv
) = min r
in
150 T
'(mink
,minv
,l
,delmin r
)
156 fun singleton (x
,v
) = T
{key
=x
,value
=v
,cnt
=1,left
=E
,right
=E
}
158 fun insert (E
,x
,v
) = T
{key
=x
,value
=v
,cnt
=1,left
=E
,right
=E
}
159 |
insert (T(set
as {key
,left
,right
,value
,...}),x
,v
) =
160 case K
.compare (key
,x
) of
161 GREATER
=> T
'(key
,value
,insert(left
,x
,v
),right
)
162 | LESS
=> T
'(key
,value
,left
,insert(right
,x
,v
))
163 | _
=> T
{key
=x
,value
=v
,left
=left
,right
=right
,cnt
= #cnt set
}
164 fun insert
' ((k
, x
), m
) = insert(m
, k
, x
)
166 fun inDomain (set
, x
) = let
168 |
mem (T(n
as {key
,left
,right
,...})) = (case K
.compare (x
,key
)
169 of GREATER
=> mem right
177 fun find (set
, x
) = let
179 |
mem (T(n
as {key
,left
,right
,...})) = (case K
.compare (x
,key
)
180 of GREATER
=> mem right
181 | EQUAL
=> SOME(#value n
)
188 fun remove (E
,x
) = raise LibBase
.NotFound
189 |
remove (set
as T
{key
,left
,right
,value
,...},x
) = (
190 case K
.compare (key
,x
)
192 val (left
', v
) = remove(left
, x
)
194 (T
'(key
, value
, left
', right
), v
)
197 val (right
', v
) = remove (right
, x
)
199 (T
'(key
, value
, left
, right
'), v
)
201 | _
=> (delete
'(left
,right
),value
)
204 fun listItems d
= let
206 |
d2l (T
{key
,value
,left
,right
,...}, l
) =
207 d2l(left
, value
::(d2l(right
,l
)))
212 fun listItemsi d
= let
214 |
d2l (T
{key
,value
,left
,right
,...}, l
) =
215 d2l(left
, (key
,value
)::(d2l(right
,l
)))
222 |
d2l (T
{key
,left
,right
,...}, l
) = d2l(left
, key
::(d2l(right
,l
)))
228 fun next ((t
as T
{right
, ...})::rest
) = (t
, left(right
, rest
))
230 and left (E
, rest
) = rest
231 |
left (t
as T
{left
=l
, ...}, rest
) = left(l
, t
::rest
)
233 fun collate
cmpRng (s1
, s2
) = let
234 fun cmp (t1
, t2
) = (case (next t1
, next t2
)
235 of ((E
, _
), (E
, _
)) => EQUAL
236 |
((E
, _
), _
) => LESS
237 |
(_
, (E
, _
)) => GREATER
238 |
((T
{key
=x1
, value
=y1
, ...}, r1
), (T
{key
=x2
, value
=y2
, ...}, r2
)) => (
239 case Key
.compare(x1
, x2
)
240 of EQUAL
=> (case cmpRng(y1
, y2
)
241 of EQUAL
=> cmp (r1
, r2
)
248 cmp (left(s1
, []), left(s2
, []))
254 | app
' (T
{key
,value
,left
,right
,...}) = (
255 app
' left
; f(key
, value
); app
' right
)
261 | app
' (T
{value
,left
,right
,...}) = (
262 app
' left
; f value
; app
' right
)
269 | map
' (T
{key
,value
,left
,right
,cnt
}) = let
270 val left
' = map
' left
271 val value
' = f(key
, value
)
272 val right
' = map
' right
274 T
{cnt
=cnt
, key
=key
, value
=value
', left
= left
', right
= right
'}
279 fun map f d
= mapi (fn (_
, x
) => f x
) d
281 fun foldli f init d
= let
283 |
fold (T
{key
,value
,left
,right
,...}, v
) =
284 fold (right
, f(key
, value
, fold(left
, v
)))
288 fun foldl f init d
= foldli (fn (_
, v
, accum
) => f (v
, accum
)) init d
290 fun foldri f init d
= let
292 |
fold (T
{key
,value
,left
,right
,...},v
) =
293 fold (left
, f(key
, value
, fold(right
, v
)))
297 fun foldr f init d
= foldri (fn (_
, v
, accum
) => f (v
, accum
)) init d
299 (** To be implemented
**
300 val filter
: ('a
-> bool) -> 'a map
-> 'a map
301 val filteri
: (Key
.ord_key
* 'a
-> bool) -> 'a map
-> 'a map
306 (* the following are generic implementations
of the unionWith
, intersectWith
,
307 * and mergeWith operetions
. These should be specialized for the internal
308 * representations at some point
.
310 fun unionWith
f (m1
, m2
) = let
311 fun ins
f (key
, x
, m
) = (case find(m
, key
)
312 of NONE
=> insert(m
, key
, x
)
313 |
(SOME x
') => insert(m
, key
, f(x
, x
'))
316 if (numItems m1
> numItems m2
)
317 then foldli (ins (fn (a
, b
) => f (b
, a
))) m1 m2
318 else foldli (ins f
) m2 m1
320 fun unionWithi
f (m1
, m2
) = let
321 fun ins
f (key
, x
, m
) = (case find(m
, key
)
322 of NONE
=> insert(m
, key
, x
)
323 |
(SOME x
') => insert(m
, key
, f(key
, x
, x
'))
326 if (numItems m1
> numItems m2
)
327 then foldli (ins (fn (k
, a
, b
) => f (k
, b
, a
))) m1 m2
328 else foldli (ins f
) m2 m1
331 fun intersectWith
f (m1
, m2
) = let
332 (* iterate over the elements
of m1
, checking for membership
in m2
*)
333 fun intersect
f (m1
, m2
) = let
334 fun ins (key
, x
, m
) = (case find(m2
, key
)
336 |
(SOME x
') => insert(m
, key
, f(x
, x
'))
342 if (numItems m1
> numItems m2
)
343 then intersect
f (m1
, m2
)
344 else intersect (fn (a
, b
) => f(b
, a
)) (m2
, m1
)
346 fun intersectWithi
f (m1
, m2
) = let
347 (* iterate over the elements
of m1
, checking for membership
in m2
*)
348 fun intersect
f (m1
, m2
) = let
349 fun ins (key
, x
, m
) = (case find(m2
, key
)
351 |
(SOME x
') => insert(m
, key
, f(key
, x
, x
'))
357 if (numItems m1
> numItems m2
)
358 then intersect
f (m1
, m2
)
359 else intersect (fn (k
, a
, b
) => f(k
, b
, a
)) (m2
, m1
)
362 fun mergeWith
f (m1
, m2
) = let
363 fun merge ([], [], m
) = m
364 |
merge ((k1
, x1
)::r1
, [], m
) = mergef (k1
, SOME x1
, NONE
, r1
, [], m
)
365 |
merge ([], (k2
, x2
)::r2
, m
) = mergef (k2
, NONE
, SOME x2
, [], r2
, m
)
366 |
merge (m1
as ((k1
, x1
)::r1
), m2
as ((k2
, x2
)::r2
), m
) = (
367 case Key
.compare (k1
, k2
)
368 of LESS
=> mergef (k1
, SOME x1
, NONE
, r1
, m2
, m
)
369 | EQUAL
=> mergef (k1
, SOME x1
, SOME x2
, r1
, r2
, m
)
370 | GREATER
=> mergef (k2
, NONE
, SOME x2
, m1
, r2
, m
)
372 and mergef (k
, x1
, x2
, r1
, r2
, m
) = (case f (x1
, x2
)
373 of NONE
=> merge (r1
, r2
, m
)
374 | SOME y
=> merge (r1
, r2
, insert(m
, k
, y
))
377 merge (listItemsi m1
, listItemsi m2
, empty
)
379 fun mergeWithi
f (m1
, m2
) = let
380 fun merge ([], [], m
) = m
381 |
merge ((k1
, x1
)::r1
, [], m
) = mergef (k1
, SOME x1
, NONE
, r1
, [], m
)
382 |
merge ([], (k2
, x2
)::r2
, m
) = mergef (k2
, NONE
, SOME x2
, [], r2
, m
)
383 |
merge (m1
as ((k1
, x1
)::r1
), m2
as ((k2
, x2
)::r2
), m
) = (
384 case Key
.compare (k1
, k2
)
385 of LESS
=> mergef (k1
, SOME x1
, NONE
, r1
, m2
, m
)
386 | EQUAL
=> mergef (k1
, SOME x1
, SOME x2
, r1
, r2
, m
)
387 | GREATER
=> mergef (k2
, NONE
, SOME x2
, m1
, r2
, m
)
389 and mergef (k
, x1
, x2
, r1
, r2
, m
) = (case f (k
, x1
, x2
)
390 of NONE
=> merge (r1
, r2
, m
)
391 | SOME y
=> merge (r1
, r2
, insert(m
, k
, y
))
394 merge (listItemsi m1
, listItemsi m2
, empty
)
397 (* this is a generic implementation
of filter
. It should
398 * be specialized to the data
-structure at some point
.
400 fun filter predFn m
= let
401 fun f (key
, item
, m
) = if predFn item
402 then insert(m
, key
, item
)
407 fun filteri predFn m
= let
408 fun f (key
, item
, m
) = if predFn(key
, item
)
409 then insert(m
, key
, item
)
415 (* this is a generic implementation
of mapPartial
. It should
416 * be specialized to the data
-structure at some point
.
418 fun mapPartial f m
= let
419 fun g (key
, item
, m
) = (case f item
421 |
(SOME item
') => insert(m
, key
, item
')
426 fun mapPartiali f m
= let
427 fun g (key
, item
, m
) = (case f(key
, item
)
429 |
(SOME item
') => insert(m
, key
, item
')
435 end (* functor BinaryMapFn
*)