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