Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/comp-lib/mapf.sml
ViewVC logotype

Annotation of /sml/trunk/src/comp-lib/mapf.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 246 - (view) (download)

1 : monnier 245 (* mapf.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     signature ORDSET =
8 :     sig
9 :     type elem
10 :     val < : elem * elem -> bool
11 :     end
12 :    
13 :     signature MAPF =
14 :     sig
15 :     structure S : ORDSET
16 :     type 'a map
17 :     val empty : 'a map
18 :     val singleton : S.elem * 'a -> 'a map
19 :     val overlay : 'a map * 'a map -> 'a map
20 :     val merge : ('a * 'a -> 'a) -> 'a map * 'a map -> 'a map
21 :     val add : 'a map * S.elem * 'a -> 'a map
22 :     exception MapF
23 :     val lookup : 'a map -> S.elem -> 'a
24 :     val members : 'a map -> (S.elem * 'a) list
25 :     val cardinality : 'a map -> int
26 :     val difference : 'a map * 'b map -> 'a map
27 :     val delete : S.elem * 'a map -> 'a map
28 :     end
29 :    
30 :     (*
31 :     Copyright 1992 Stephen Adams.
32 :    
33 :     ALTERED FROM THE ORIGINAL by Andrew Appel
34 :    
35 :     This software may be used freely provided that:
36 :     1. This copyright notice is attached to any copy, derived work,
37 :     or work including all or part of this software.
38 :     2. Any derived work must contain a prominent notice stating that
39 :     it has been altered from the original.
40 :    
41 :     *)
42 :    
43 :     (* Name(s): Stephen Adams.
44 :     Department, Institution: Electronics & Computer Science,
45 :     University of Southampton
46 :     Address: Electronics & Computer Science
47 :     University of Southampton
48 :     Southampton SO9 5NH
49 :     Great Britain
50 :     E-mail: sra@ecs.soton.ac.uk
51 :    
52 :     Comments:
53 :    
54 :     1. The implementation is based on Binary search trees of Bounded
55 :     Balance, similar to Nievergelt & Reingold, SIAM J. Computing
56 :     2(1), March 1973. The main advantage of these trees is that
57 :     they keep the size of the tree in the node, giving a constant
58 :     time size operation.
59 :    
60 :     2. The bounded balance criterion is simpler than N&R's alpha.
61 :     Simply, one subtree must not have more than `weight' times as
62 :     many elements as the opposite subtree. Rebalancing is
63 :     guaranteed to reinstate the criterion for weight>2.23, but
64 :     the occasional incorrect behaviour for weight=2 is not
65 :     detrimental to performance.
66 :    
67 :     *)
68 :    
69 :     functor MapF(S : ORDSET) : MAPF =
70 :     struct
71 :     structure S=S
72 :    
73 :     val weight = 3
74 :    
75 :     datatype 'a map = E | T of S.elem * 'a * int * 'a map * 'a map
76 :    
77 :     fun size E = 0
78 :     | size (T(_,_,n,_,_)) = n
79 :    
80 :     (*fun N(v,a,l,r) = T(v,a,1+size(l)+size(r),l,r)*)
81 :     fun N(v,a,E, E) = T(v,a,1,E,E)
82 :     | N(v,a,E, r as T(_,_,n,_,_)) = T(v,a,n+1,E,r)
83 :     | N(v,a,l as T(_,_,n,_,_),E) = T(v,a,n+1,l,E)
84 :     | N(v,a,l as T(_,_,n,_,_),r as T(_,_,m,_,_)) = T(v,a,n+m+1,l,r)
85 :    
86 :     fun single_L (a,a',x,T(b,b',_,y,z)) = N(b,b',N(a,a',x,y),z)
87 :     | single_L _ = raise Match
88 :     fun single_R (b,b',T(a,a',_,x,y),z) = N(a,a',x,N(b,b',y,z))
89 :     | single_R _ = raise Match
90 :     fun double_L (a,a',w,T(c,c',_,T(b,b',_,x,y),z)) =
91 :     N(b,b',N(a,a',w,x),N(c,c',y,z))
92 :     | double_L _ = raise Match
93 :     fun double_R (c,c',T(a,a',_,w,T(b,b',_,x,y)),z) = N(b,b',N(a,a',w,x),N(c,c',y,z))
94 :     | double_R _ = raise Match
95 :    
96 :     fun T' (v,v',E,E) = T(v,v',1,E,E)
97 :     | T' (v,v',E,r as T(_,_,_,E,E)) = T(v,v',2,E,r)
98 :     | T' (v,v',l as T(_,_,_,E,E),E) = T(v,v',2,l,E)
99 :    
100 :     | T' (p as (_,_,E,T(_,_,_,T(_,_,_,_,_),E))) = double_L p
101 :     | T' (p as (_,_,T(_,_,_,E,T(_,_,_,_,_)),E)) = double_R p
102 :    
103 :     (* these cases almost never happen with small weight*)
104 :     | T' (p as (_,_,E,T(_,_,_,T(_,_,ln,_,_),T(_,_,rn,_,_)))) =
105 :     if ln<rn then single_L p else double_L p
106 :     | T' (p as (_,_,T(_,_,_,T(_,_,ln,_,_),T(_,_,rn,_,_)),E)) =
107 :     if ln>rn then single_R p else double_R p
108 :    
109 :     | T' (p as (_,_,E,T(_,_,_,E,_))) = single_L p
110 :     | T' (p as (_,_,T(_,_,_,_,E),E)) = single_R p
111 :    
112 :     | T' (p as (v,v',l as T(lv,lv',ln,ll,lr),r as T(rv,rv',rn,rl,rr))) =
113 :     if rn>=weight*ln then (*right is too big*)
114 :     let val rln = size rl
115 :     val rrn = size rr
116 :     in
117 :     if rln < rrn then single_L p else double_L p
118 :     end
119 :    
120 :     else if ln>=weight*rn then (*left is too big*)
121 :     let val lln = size ll
122 :     val lrn = size lr
123 :     in
124 :     if lrn < lln then single_R p else double_R p
125 :     end
126 :    
127 :     else
128 :     T(v,v',ln+rn+1,l,r)
129 :    
130 :     fun add (E,x,x') = T(x,x',1,E,E)
131 :     | add (T(v,v',w,l,r),x,x') =
132 :     if S.<(x,v) then T'(v,v',add(l,x,x'),r)
133 :     else if S.<(v,x) then T'(v,v',l,add(r,x,x'))
134 :     (* replace v,v' with x,x'! (blume/4/96) *)
135 :     else T(x,x',w,l,r)
136 :    
137 :     fun concat3 (E,v,v',r) = add(r,v,v')
138 :     | concat3 (l,v,v',E) = add(l,v,v')
139 :     | concat3 (l as T(v1,v1',n1,l1,r1), v, v', r as T(v2,v2',n2,l2,r2)) =
140 :     if weight*n1 < n2 then T'(v2,v2',concat3(l,v,v',l2),r2)
141 :     else if weight*n2 < n1 then T'(v1,v1',l1,concat3(r1,v,v',r))
142 :     else N(v,v',l,r)
143 :    
144 :     fun split (E, x) = (E, NONE, E)
145 :     | split (T(v,v',_,l,r), x) =
146 :     if S.<(x,v) then let val (ll,z,lr) = split(l,x)
147 :     in (ll,z,concat3(lr,v,v',r))
148 :     end
149 :     else if S.<(v,x)
150 :     then let val (rl,z,rr) = split(r,x)
151 :     in (concat3(l,v,v',rl),z,rr)
152 :     end
153 :     else (l,SOME v',r)
154 :    
155 :     fun split_lt (E,x) = E
156 :     | split_lt (t as T(v,v',_,l,r),x) =
157 :     if S.<(x,v) then split_lt(l,x)
158 :     else if S.<(v,x) then concat3(l,v,v',split_lt(r,x))
159 :     else l
160 :    
161 :     fun split_gt (E,x) = E
162 :     | split_gt (t as T(v,v',_,l,r),x) =
163 :     if S.<(v,x) then split_gt(r,x)
164 :     else if S.<(x,v) then concat3(split_gt(l,x),v,v',r)
165 :     else r
166 :    
167 :     and delmin (T(v,v',_,E,r)) = (v,v',r)
168 :     | delmin (T(v,v',_,l,r)) = let val (x,x',l') = delmin l
169 :     in (x,x',T'(v,v',l',r))
170 :     end
171 :     | delmin _ = raise Match
172 :    
173 :     and cat2 (E,r) = r
174 :     | cat2 (l,E) = l
175 :     | cat2 (l,r) = let val (x,x',r') = delmin r
176 :     in T'(x,x',l,r')
177 :     end
178 :    
179 :     fun concat (E, s2) = s2
180 :     | concat (s1, E) = s1
181 :     | concat (t1 as T(v1,v1',n1,l1,r1), t2 as T(v2,v2',n2,l2,r2)) =
182 :     if weight*n1 < n2 then T'(v2,v2',concat(t1,l2),r2)
183 :     else if weight*n2 < n1 then T'(v1,v1',l1,concat(r1,t2))
184 :     else cat2(t1,t2)
185 :    
186 :     fun fold(f,base,set) =
187 :     let fun fold'(base,E) = base
188 :     | fold'(base,T(v,v',_,l,r)) = fold'(f((v,v'),fold'(base,r)),l)
189 :     in
190 :     fold'(base,set)
191 :     end
192 :    
193 :    
194 :     val empty = E
195 :    
196 :     fun singleton (x,x') = T(x,x',1,E,E)
197 :    
198 :     fun merge combine =
199 :     let fun f (E,s2) = s2
200 :     | f (s1,E) = s1
201 :     | f (s1 as T(v,v',_,l,r),s2) =
202 :     case split(s2,v)
203 :     of (l2,SOME vv', r2) => concat3(f(l,l2), v, combine(v',vv'), f(r,r2))
204 :     | (l2, NONE, r2) => concat3(f(l,l2),v,v',f(r,r2))
205 :     in f
206 :     end
207 :    
208 :     fun overlay x = merge #1 x
209 :    
210 :     fun difference (E,s) = E
211 :     | difference (s,E) = s
212 :     | difference (s, T(v,_,_,l,r)) =
213 :     let val l2 = split_lt(s,v)
214 :     val r2 = split_gt(s,v)
215 :     in
216 :     concat(difference(l2,l),difference(r2,r))
217 :     end
218 :    
219 :     exception MapF
220 :    
221 :     fun lookup set x =
222 :     let fun mem E = raise MapF
223 :     | mem (T(v,v',_,l,r)) =
224 :     if S.<(x,v) then mem l else if S.<(v,x) then mem r else v'
225 :     in mem set end
226 :    
227 :     fun members set = fold(op::,[],set)
228 :    
229 :     fun cardinality E = 0
230 :     | cardinality (T(_,_,n,_,_)) = n
231 :    
232 :     fun delete (x,E) = E
233 :     | delete (x,set as T(v,v',_,l,r)) =
234 :     if S.<(x,v) then T'(v,v',delete(x,l),r)
235 :     else if S.<(v,x) then T'(v,v',l,delete(x,r))
236 :     else cat2(l,r)
237 :    
238 :     end
239 :    
240 :     (*
241 :     * $Log$
242 :     *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0