Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/mmap.ml | ||
---|---|---|
11 | 11 |
(* *) |
12 | 12 |
(***********************************************************************) |
13 | 13 |
|
14 |
module type OrderedType = |
|
15 |
sig |
|
16 |
type t |
|
17 |
val compare: t -> t -> int |
|
18 |
end |
|
19 |
|
|
20 |
module type S = |
|
21 |
sig |
|
22 |
type key |
|
23 |
type +'a t |
|
24 |
val empty: 'a t |
|
25 |
val is_empty: 'a t -> bool |
|
26 |
val mem: key -> 'a t -> bool |
|
27 |
val add: key -> 'a -> 'a t -> 'a t |
|
28 |
val singleton: key -> 'a -> 'a t |
|
29 |
val remove: key -> 'a t -> 'a t |
|
30 |
val merge: |
|
31 |
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t |
|
32 |
val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int |
|
33 |
val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool |
|
34 |
val iter: (key -> 'a -> unit) -> 'a t -> unit |
|
35 |
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b |
|
36 |
val for_all: (key -> 'a -> bool) -> 'a t -> bool |
|
37 |
val exists: (key -> 'a -> bool) -> 'a t -> bool |
|
38 |
val filter: (key -> 'a -> bool) -> 'a t -> 'a t |
|
39 |
val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t |
|
40 |
val cardinal: 'a t -> int |
|
41 |
val bindings: 'a t -> (key * 'a) list |
|
42 |
val min_binding: 'a t -> (key * 'a) |
|
43 |
val max_binding: 'a t -> (key * 'a) |
|
44 |
val choose: 'a t -> (key * 'a) |
|
45 |
val split: key -> 'a t -> 'a t * 'a option * 'a t |
|
46 |
val find: key -> 'a t -> 'a |
|
47 |
val map: ('a -> 'b) -> 'a t -> 'b t |
|
48 |
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t |
|
49 |
end |
|
50 |
|
|
51 |
module Make(Ord: OrderedType) = struct |
|
52 |
|
|
53 |
type key = Ord.t |
|
54 |
|
|
55 |
type 'a t = |
|
56 |
Empty |
|
57 |
| Node of 'a t * key * 'a * 'a t * int |
|
58 |
|
|
59 |
let height = function |
|
60 |
Empty -> 0 |
|
61 |
| Node(_,_,_,_,h) -> h |
|
62 |
|
|
63 |
let create l x d r = |
|
64 |
let hl = height l and hr = height r in |
|
65 |
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) |
|
66 |
|
|
67 |
let singleton x d = Node(Empty, x, d, Empty, 1) |
|
68 |
|
|
69 |
let bal l x d r = |
|
70 |
let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in |
|
71 |
let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in |
|
72 |
if hl > hr + 2 then begin |
|
73 |
match l with |
|
74 |
Empty -> invalid_arg "Map.bal" |
|
75 |
| Node(ll, lv, ld, lr, _) -> |
|
76 |
if height ll >= height lr then |
|
77 |
create ll lv ld (create lr x d r) |
|
78 |
else begin |
|
79 |
match lr with |
|
80 |
Empty -> invalid_arg "Map.bal" |
|
81 |
| Node(lrl, lrv, lrd, lrr, _)-> |
|
82 |
create (create ll lv ld lrl) lrv lrd (create lrr x d r) |
|
83 |
end |
|
84 |
end else if hr > hl + 2 then begin |
|
85 |
match r with |
|
86 |
Empty -> invalid_arg "Map.bal" |
|
87 |
| Node(rl, rv, rd, rr, _) -> |
|
88 |
if height rr >= height rl then |
|
89 |
create (create l x d rl) rv rd rr |
|
90 |
else begin |
|
91 |
match rl with |
|
92 |
Empty -> invalid_arg "Map.bal" |
|
93 |
| Node(rll, rlv, rld, rlr, _) -> |
|
94 |
create (create l x d rll) rlv rld (create rlr rv rd rr) |
|
95 |
end |
|
96 |
end else |
|
97 |
Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) |
|
98 |
|
|
99 |
let empty = Empty |
|
100 |
|
|
101 |
let is_empty = function Empty -> true | _ -> false |
|
102 |
|
|
103 |
let rec add x data = function |
|
104 |
Empty -> |
|
105 |
Node(Empty, x, data, Empty, 1) |
|
106 |
| Node(l, v, d, r, h) -> |
|
107 |
let c = Ord.compare x v in |
|
108 |
if c = 0 then |
|
109 |
Node(l, x, data, r, h) |
|
110 |
else if c < 0 then |
|
111 |
bal (add x data l) v d r |
|
112 |
else |
|
113 |
bal l v d (add x data r) |
|
114 |
|
|
115 |
let rec find x = function |
|
116 |
Empty -> |
|
117 |
raise Not_found |
|
118 |
| Node(l, v, d, r, _) -> |
|
119 |
let c = Ord.compare x v in |
|
120 |
if c = 0 then d |
|
121 |
else find x (if c < 0 then l else r) |
|
122 |
|
|
123 |
let rec mem x = function |
|
124 |
Empty -> |
|
125 |
false |
|
126 |
| Node(l, v, _, r, _) -> |
|
127 |
let c = Ord.compare x v in |
|
128 |
c = 0 || mem x (if c < 0 then l else r) |
|
129 |
|
|
130 |
let rec min_binding = function |
|
131 |
Empty -> raise Not_found |
|
132 |
| Node(Empty, x, d, _, _) -> (x, d) |
|
133 |
| Node(l, _, _, _, _) -> min_binding l |
|
134 |
|
|
135 |
let rec max_binding = function |
|
136 |
Empty -> raise Not_found |
|
137 |
| Node(_, x, d, Empty, _) -> (x, d) |
|
138 |
| Node(_, _, _, r, _) -> max_binding r |
|
139 |
|
|
140 |
let rec remove_min_binding = function |
|
141 |
Empty -> invalid_arg "Map.remove_min_elt" |
|
142 |
| Node(Empty, _, _, r, _) -> r |
|
143 |
| Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r |
|
144 |
|
|
145 |
let merge t1 t2 = |
|
146 |
match (t1, t2) with |
|
147 |
(Empty, t) -> t |
|
148 |
| (t, Empty) -> t |
|
149 |
| (_, _) -> |
|
150 |
let (x, d) = min_binding t2 in |
|
151 |
bal t1 x d (remove_min_binding t2) |
|
152 |
|
|
153 |
let rec remove x = function |
|
154 |
Empty -> |
|
155 |
Empty |
|
156 |
| Node(l, v, d, r, _) -> |
|
157 |
let c = Ord.compare x v in |
|
158 |
if c = 0 then |
|
159 |
merge l r |
|
160 |
else if c < 0 then |
|
161 |
bal (remove x l) v d r |
|
162 |
else |
|
163 |
bal l v d (remove x r) |
|
164 |
|
|
165 |
let rec iter f = function |
|
166 |
Empty -> () |
|
167 |
| Node(l, v, d, r, _) -> |
|
168 |
iter f l; f v d; iter f r |
|
169 |
|
|
170 |
let rec map f = function |
|
171 |
Empty -> |
|
172 |
Empty |
|
173 |
| Node(l, v, d, r, h) -> |
|
174 |
let l' = map f l in |
|
175 |
let d' = f d in |
|
176 |
let r' = map f r in |
|
177 |
Node(l', v, d', r', h) |
|
178 |
|
|
179 |
let rec mapi f = function |
|
180 |
Empty -> |
|
181 |
Empty |
|
182 |
| Node(l, v, d, r, h) -> |
|
183 |
let l' = mapi f l in |
|
184 |
let d' = f v d in |
|
185 |
let r' = mapi f r in |
|
186 |
Node(l', v, d', r', h) |
|
187 |
|
|
188 |
let rec fold f m accu = |
|
189 |
match m with |
|
190 |
Empty -> accu |
|
191 |
| Node(l, v, d, r, _) -> |
|
192 |
fold f r (f v d (fold f l accu)) |
|
193 |
|
|
194 |
let rec for_all p = function |
|
195 |
Empty -> true |
|
196 |
| Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r |
|
197 |
|
|
198 |
let rec exists p = function |
|
199 |
Empty -> false |
|
200 |
| Node(l, v, d, r, _) -> p v d || exists p l || exists p r |
|
201 |
|
|
202 |
(* Beware: those two functions assume that the added k is *strictly* |
|
203 |
smaller (or bigger) than all the present keys in the tree; it |
|
204 |
does not test for equality with the current min (or max) key. |
|
205 |
|
|
206 |
Indeed, they are only used during the "join" operation which |
|
207 |
respects this precondition. |
|
208 |
*) |
|
209 |
|
|
210 |
let rec add_min_binding k v = function |
|
211 |
| Empty -> singleton k v |
|
212 |
| Node (l, x, d, r, _) -> |
|
213 |
bal (add_min_binding k v l) x d r |
|
214 |
|
|
215 |
let rec add_max_binding k v = function |
|
216 |
| Empty -> singleton k v |
|
217 |
| Node (l, x, d, r, _) -> |
|
218 |
bal l x d (add_max_binding k v r) |
|
219 |
|
|
220 |
(* Same as create and bal, but no assumptions are made on the |
|
221 |
relative heights of l and r. *) |
|
222 |
|
|
223 |
let rec join l v d r = |
|
224 |
match (l, r) with |
|
225 |
(Empty, _) -> add_min_binding v d r |
|
226 |
| (_, Empty) -> add_max_binding v d l |
|
227 |
| (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) -> |
|
228 |
if lh > rh + 2 then bal ll lv ld (join lr v d r) else |
|
229 |
if rh > lh + 2 then bal (join l v d rl) rv rd rr else |
|
230 |
create l v d r |
|
231 |
|
|
232 |
(* Merge two trees l and r into one. |
|
233 |
All elements of l must precede the elements of r. |
|
234 |
No assumption on the heights of l and r. *) |
|
235 |
|
|
236 |
let concat t1 t2 = |
|
237 |
match (t1, t2) with |
|
238 |
(Empty, t) -> t |
|
239 |
| (t, Empty) -> t |
|
240 |
| (_, _) -> |
|
241 |
let (x, d) = min_binding t2 in |
|
242 |
join t1 x d (remove_min_binding t2) |
|
243 |
|
|
244 |
let concat_or_join t1 v d t2 = |
|
245 |
match d with |
|
246 |
| Some d -> join t1 v d t2 |
|
247 |
| None -> concat t1 t2 |
|
248 |
|
|
249 |
let rec split x = function |
|
250 |
Empty -> |
|
251 |
(Empty, None, Empty) |
|
252 |
| Node(l, v, d, r, _) -> |
|
253 |
let c = Ord.compare x v in |
|
254 |
if c = 0 then (l, Some d, r) |
|
255 |
else if c < 0 then |
|
256 |
let (ll, pres, rl) = split x l in (ll, pres, join rl v d r) |
|
257 |
else |
|
258 |
let (lr, pres, rr) = split x r in (join l v d lr, pres, rr) |
|
259 |
|
|
260 |
let rec merge f s1 s2 = |
|
261 |
match (s1, s2) with |
|
262 |
(Empty, Empty) -> Empty |
|
263 |
| (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 -> |
|
264 |
let (l2, d2, r2) = split v1 s2 in |
|
265 |
concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) |
|
266 |
| (_, Node (l2, v2, d2, r2, _)) -> |
|
267 |
let (l1, d1, r1) = split v2 s1 in |
|
268 |
concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) |
|
269 |
| _ -> |
|
270 |
assert false |
|
271 |
|
|
272 |
let rec filter p = function |
|
273 |
Empty -> Empty |
|
274 |
| Node(l, v, d, r, _) -> |
|
275 |
(* call [p] in the expected left-to-right order *) |
|
276 |
let l' = filter p l in |
|
277 |
let pvd = p v d in |
|
278 |
let r' = filter p r in |
|
279 |
if pvd then join l' v d r' else concat l' r' |
|
280 |
|
|
281 |
let rec partition p = function |
|
282 |
Empty -> (Empty, Empty) |
|
283 |
| Node(l, v, d, r, _) -> |
|
284 |
(* call [p] in the expected left-to-right order *) |
|
285 |
let (lt, lf) = partition p l in |
|
286 |
let pvd = p v d in |
|
287 |
let (rt, rf) = partition p r in |
|
288 |
if pvd |
|
289 |
then (join lt v d rt, concat lf rf) |
|
290 |
else (concat lt rt, join lf v d rf) |
|
291 |
|
|
292 |
type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration |
|
293 |
|
|
294 |
let rec cons_enum m e = |
|
295 |
match m with |
|
296 |
Empty -> e |
|
297 |
| Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) |
|
298 |
|
|
299 |
let compare cmp m1 m2 = |
|
300 |
let rec compare_aux e1 e2 = |
|
301 |
match (e1, e2) with |
|
302 |
(End, End) -> 0 |
|
303 |
| (End, _) -> -1 |
|
304 |
| (_, End) -> 1 |
|
305 |
| (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> |
|
306 |
let c = Ord.compare v1 v2 in |
|
307 |
if c <> 0 then c else |
|
308 |
let c = cmp d1 d2 in |
|
309 |
if c <> 0 then c else |
|
310 |
compare_aux (cons_enum r1 e1) (cons_enum r2 e2) |
|
311 |
in compare_aux (cons_enum m1 End) (cons_enum m2 End) |
|
312 |
|
|
313 |
let equal cmp m1 m2 = |
|
314 |
let rec equal_aux e1 e2 = |
|
315 |
match (e1, e2) with |
|
316 |
(End, End) -> true |
|
317 |
| (End, _) -> false |
|
318 |
| (_, End) -> false |
|
319 |
| (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> |
|
320 |
Ord.compare v1 v2 = 0 && cmp d1 d2 && |
|
321 |
equal_aux (cons_enum r1 e1) (cons_enum r2 e2) |
|
322 |
in equal_aux (cons_enum m1 End) (cons_enum m2 End) |
|
323 |
|
|
324 |
let rec cardinal = function |
|
325 |
Empty -> 0 |
|
326 |
| Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r |
|
327 |
|
|
328 |
let rec bindings_aux accu = function |
|
329 |
Empty -> accu |
|
330 |
| Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l |
|
331 |
|
|
332 |
let bindings s = |
|
333 |
bindings_aux [] s |
|
334 |
|
|
335 |
let choose = min_binding |
|
14 |
module type OrderedType = sig |
|
15 |
type t |
|
336 | 16 |
|
17 |
val compare : t -> t -> int |
|
18 |
end |
|
19 |
|
|
20 |
module type S = sig |
|
21 |
type key |
|
22 |
|
|
23 |
type +'a t |
|
24 |
|
|
25 |
val empty : 'a t |
|
26 |
|
|
27 |
val is_empty : 'a t -> bool |
|
28 |
|
|
29 |
val mem : key -> 'a t -> bool |
|
30 |
|
|
31 |
val add : key -> 'a -> 'a t -> 'a t |
|
32 |
|
|
33 |
val singleton : key -> 'a -> 'a t |
|
34 |
|
|
35 |
val remove : key -> 'a t -> 'a t |
|
36 |
|
|
37 |
val merge : |
|
38 |
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t |
|
39 |
|
|
40 |
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int |
|
41 |
|
|
42 |
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool |
|
43 |
|
|
44 |
val iter : (key -> 'a -> unit) -> 'a t -> unit |
|
45 |
|
|
46 |
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b |
|
47 |
|
|
48 |
val for_all : (key -> 'a -> bool) -> 'a t -> bool |
|
49 |
|
|
50 |
val exists : (key -> 'a -> bool) -> 'a t -> bool |
|
51 |
|
|
52 |
val filter : (key -> 'a -> bool) -> 'a t -> 'a t |
|
53 |
|
|
54 |
val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t |
|
55 |
|
|
56 |
val cardinal : 'a t -> int |
|
57 |
|
|
58 |
val bindings : 'a t -> (key * 'a) list |
|
59 |
|
|
60 |
val min_binding : 'a t -> key * 'a |
|
61 |
|
|
62 |
val max_binding : 'a t -> key * 'a |
|
63 |
|
|
64 |
val choose : 'a t -> key * 'a |
|
65 |
|
|
66 |
val split : key -> 'a t -> 'a t * 'a option * 'a t |
|
67 |
|
|
68 |
val find : key -> 'a t -> 'a |
|
69 |
|
|
70 |
val map : ('a -> 'b) -> 'a t -> 'b t |
|
71 |
|
|
72 |
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t |
|
73 |
end |
|
74 |
|
|
75 |
module Make (Ord : OrderedType) = struct |
|
76 |
type key = Ord.t |
|
77 |
|
|
78 |
type 'a t = Empty | Node of 'a t * key * 'a * 'a t * int |
|
79 |
|
|
80 |
let height = function Empty -> 0 | Node (_, _, _, _, h) -> h |
|
81 |
|
|
82 |
let create l x d r = |
|
83 |
let hl = height l and hr = height r in |
|
84 |
Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) |
|
85 |
|
|
86 |
let singleton x d = Node (Empty, x, d, Empty, 1) |
|
87 |
|
|
88 |
let bal l x d r = |
|
89 |
let hl = match l with Empty -> 0 | Node (_, _, _, _, h) -> h in |
|
90 |
let hr = match r with Empty -> 0 | Node (_, _, _, _, h) -> h in |
|
91 |
if hl > hr + 2 then |
|
92 |
match l with |
|
93 |
| Empty -> |
|
94 |
invalid_arg "Map.bal" |
|
95 |
| Node (ll, lv, ld, lr, _) -> ( |
|
96 |
if height ll >= height lr then create ll lv ld (create lr x d r) |
|
97 |
else |
|
98 |
match lr with |
|
99 |
| Empty -> |
|
100 |
invalid_arg "Map.bal" |
|
101 |
| Node (lrl, lrv, lrd, lrr, _) -> |
|
102 |
create (create ll lv ld lrl) lrv lrd (create lrr x d r)) |
|
103 |
else if hr > hl + 2 then |
|
104 |
match r with |
|
105 |
| Empty -> |
|
106 |
invalid_arg "Map.bal" |
|
107 |
| Node (rl, rv, rd, rr, _) -> ( |
|
108 |
if height rr >= height rl then create (create l x d rl) rv rd rr |
|
109 |
else |
|
110 |
match rl with |
|
111 |
| Empty -> |
|
112 |
invalid_arg "Map.bal" |
|
113 |
| Node (rll, rlv, rld, rlr, _) -> |
|
114 |
create (create l x d rll) rlv rld (create rlr rv rd rr)) |
|
115 |
else Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) |
|
116 |
|
|
117 |
let empty = Empty |
|
118 |
|
|
119 |
let is_empty = function Empty -> true | _ -> false |
|
120 |
|
|
121 |
let rec add x data = function |
|
122 |
| Empty -> |
|
123 |
Node (Empty, x, data, Empty, 1) |
|
124 |
| Node (l, v, d, r, h) -> |
|
125 |
let c = Ord.compare x v in |
|
126 |
if c = 0 then Node (l, x, data, r, h) |
|
127 |
else if c < 0 then bal (add x data l) v d r |
|
128 |
else bal l v d (add x data r) |
|
129 |
|
|
130 |
let rec find x = function |
|
131 |
| Empty -> |
|
132 |
raise Not_found |
|
133 |
| Node (l, v, d, r, _) -> |
|
134 |
let c = Ord.compare x v in |
|
135 |
if c = 0 then d else find x (if c < 0 then l else r) |
|
136 |
|
|
137 |
let rec mem x = function |
|
138 |
| Empty -> |
|
139 |
false |
|
140 |
| Node (l, v, _, r, _) -> |
|
141 |
let c = Ord.compare x v in |
|
142 |
c = 0 || mem x (if c < 0 then l else r) |
|
143 |
|
|
144 |
let rec min_binding = function |
|
145 |
| Empty -> |
|
146 |
raise Not_found |
|
147 |
| Node (Empty, x, d, _, _) -> |
|
148 |
x, d |
|
149 |
| Node (l, _, _, _, _) -> |
|
150 |
min_binding l |
|
151 |
|
|
152 |
let rec max_binding = function |
|
153 |
| Empty -> |
|
154 |
raise Not_found |
|
155 |
| Node (_, x, d, Empty, _) -> |
|
156 |
x, d |
|
157 |
| Node (_, _, _, r, _) -> |
|
158 |
max_binding r |
|
159 |
|
|
160 |
let rec remove_min_binding = function |
|
161 |
| Empty -> |
|
162 |
invalid_arg "Map.remove_min_elt" |
|
163 |
| Node (Empty, _, _, r, _) -> |
|
164 |
r |
|
165 |
| Node (l, x, d, r, _) -> |
|
166 |
bal (remove_min_binding l) x d r |
|
167 |
|
|
168 |
let merge t1 t2 = |
|
169 |
match t1, t2 with |
|
170 |
| Empty, t -> |
|
171 |
t |
|
172 |
| t, Empty -> |
|
173 |
t |
|
174 |
| _, _ -> |
|
175 |
let x, d = min_binding t2 in |
|
176 |
bal t1 x d (remove_min_binding t2) |
|
177 |
|
|
178 |
let rec remove x = function |
|
179 |
| Empty -> |
|
180 |
Empty |
|
181 |
| Node (l, v, d, r, _) -> |
|
182 |
let c = Ord.compare x v in |
|
183 |
if c = 0 then merge l r |
|
184 |
else if c < 0 then bal (remove x l) v d r |
|
185 |
else bal l v d (remove x r) |
|
186 |
|
|
187 |
let rec iter f = function |
|
188 |
| Empty -> |
|
189 |
() |
|
190 |
| Node (l, v, d, r, _) -> |
|
191 |
iter f l; |
|
192 |
f v d; |
|
193 |
iter f r |
|
194 |
|
|
195 |
let rec map f = function |
|
196 |
| Empty -> |
|
197 |
Empty |
|
198 |
| Node (l, v, d, r, h) -> |
|
199 |
let l' = map f l in |
|
200 |
let d' = f d in |
|
201 |
let r' = map f r in |
|
202 |
Node (l', v, d', r', h) |
|
203 |
|
|
204 |
let rec mapi f = function |
|
205 |
| Empty -> |
|
206 |
Empty |
|
207 |
| Node (l, v, d, r, h) -> |
|
208 |
let l' = mapi f l in |
|
209 |
let d' = f v d in |
|
210 |
let r' = mapi f r in |
|
211 |
Node (l', v, d', r', h) |
|
212 |
|
|
213 |
let rec fold f m accu = |
|
214 |
match m with |
|
215 |
| Empty -> |
|
216 |
accu |
|
217 |
| Node (l, v, d, r, _) -> |
|
218 |
fold f r (f v d (fold f l accu)) |
|
219 |
|
|
220 |
let rec for_all p = function |
|
221 |
| Empty -> |
|
222 |
true |
|
223 |
| Node (l, v, d, r, _) -> |
|
224 |
p v d && for_all p l && for_all p r |
|
225 |
|
|
226 |
let rec exists p = function |
|
227 |
| Empty -> |
|
228 |
false |
|
229 |
| Node (l, v, d, r, _) -> |
|
230 |
p v d || exists p l || exists p r |
|
231 |
|
|
232 |
(* Beware: those two functions assume that the added k is *strictly* smaller |
|
233 |
(or bigger) than all the present keys in the tree; it does not test for |
|
234 |
equality with the current min (or max) key. |
|
235 |
|
|
236 |
Indeed, they are only used during the "join" operation which respects this |
|
237 |
precondition. *) |
|
238 |
|
|
239 |
let rec add_min_binding k v = function |
|
240 |
| Empty -> |
|
241 |
singleton k v |
|
242 |
| Node (l, x, d, r, _) -> |
|
243 |
bal (add_min_binding k v l) x d r |
|
244 |
|
|
245 |
let rec add_max_binding k v = function |
|
246 |
| Empty -> |
|
247 |
singleton k v |
|
248 |
| Node (l, x, d, r, _) -> |
|
249 |
bal l x d (add_max_binding k v r) |
|
250 |
|
|
251 |
(* Same as create and bal, but no assumptions are made on the relative heights |
|
252 |
of l and r. *) |
|
253 |
|
|
254 |
let rec join l v d r = |
|
255 |
match l, r with |
|
256 |
| Empty, _ -> |
|
257 |
add_min_binding v d r |
|
258 |
| _, Empty -> |
|
259 |
add_max_binding v d l |
|
260 |
| Node (ll, lv, ld, lr, lh), Node (rl, rv, rd, rr, rh) -> |
|
261 |
if lh > rh + 2 then bal ll lv ld (join lr v d r) |
|
262 |
else if rh > lh + 2 then bal (join l v d rl) rv rd rr |
|
263 |
else create l v d r |
|
264 |
|
|
265 |
(* Merge two trees l and r into one. All elements of l must precede the |
|
266 |
elements of r. No assumption on the heights of l and r. *) |
|
267 |
|
|
268 |
let concat t1 t2 = |
|
269 |
match t1, t2 with |
|
270 |
| Empty, t -> |
|
271 |
t |
|
272 |
| t, Empty -> |
|
273 |
t |
|
274 |
| _, _ -> |
|
275 |
let x, d = min_binding t2 in |
|
276 |
join t1 x d (remove_min_binding t2) |
|
277 |
|
|
278 |
let concat_or_join t1 v d t2 = |
|
279 |
match d with Some d -> join t1 v d t2 | None -> concat t1 t2 |
|
280 |
|
|
281 |
let rec split x = function |
|
282 |
| Empty -> |
|
283 |
Empty, None, Empty |
|
284 |
| Node (l, v, d, r, _) -> |
|
285 |
let c = Ord.compare x v in |
|
286 |
if c = 0 then l, Some d, r |
|
287 |
else if c < 0 then |
|
288 |
let ll, pres, rl = split x l in |
|
289 |
ll, pres, join rl v d r |
|
290 |
else |
|
291 |
let lr, pres, rr = split x r in |
|
292 |
join l v d lr, pres, rr |
|
293 |
|
|
294 |
let rec merge f s1 s2 = |
|
295 |
match s1, s2 with |
|
296 |
| Empty, Empty -> |
|
297 |
Empty |
|
298 |
| Node (l1, v1, d1, r1, h1), _ when h1 >= height s2 -> |
|
299 |
let l2, d2, r2 = split v1 s2 in |
|
300 |
concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2) |
|
301 |
| _, Node (l2, v2, d2, r2, _) -> |
|
302 |
let l1, d1, r1 = split v2 s1 in |
|
303 |
concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2) |
|
304 |
| _ -> |
|
305 |
assert false |
|
306 |
|
|
307 |
let rec filter p = function |
|
308 |
| Empty -> |
|
309 |
Empty |
|
310 |
| Node (l, v, d, r, _) -> |
|
311 |
(* call [p] in the expected left-to-right order *) |
|
312 |
let l' = filter p l in |
|
313 |
let pvd = p v d in |
|
314 |
let r' = filter p r in |
|
315 |
if pvd then join l' v d r' else concat l' r' |
|
316 |
|
|
317 |
let rec partition p = function |
|
318 |
| Empty -> |
|
319 |
Empty, Empty |
|
320 |
| Node (l, v, d, r, _) -> |
|
321 |
(* call [p] in the expected left-to-right order *) |
|
322 |
let lt, lf = partition p l in |
|
323 |
let pvd = p v d in |
|
324 |
let rt, rf = partition p r in |
|
325 |
if pvd then join lt v d rt, concat lf rf else concat lt rt, join lf v d rf |
|
326 |
|
|
327 |
type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration |
|
328 |
|
|
329 |
let rec cons_enum m e = |
|
330 |
match m with |
|
331 |
| Empty -> |
|
332 |
e |
|
333 |
| Node (l, v, d, r, _) -> |
|
334 |
cons_enum l (More (v, d, r, e)) |
|
335 |
|
|
336 |
let compare cmp m1 m2 = |
|
337 |
let rec compare_aux e1 e2 = |
|
338 |
match e1, e2 with |
|
339 |
| End, End -> |
|
340 |
0 |
|
341 |
| End, _ -> |
|
342 |
-1 |
|
343 |
| _, End -> |
|
344 |
1 |
|
345 |
| More (v1, d1, r1, e1), More (v2, d2, r2, e2) -> |
|
346 |
let c = Ord.compare v1 v2 in |
|
347 |
if c <> 0 then c |
|
348 |
else |
|
349 |
let c = cmp d1 d2 in |
|
350 |
if c <> 0 then c else compare_aux (cons_enum r1 e1) (cons_enum r2 e2) |
|
351 |
in |
|
352 |
compare_aux (cons_enum m1 End) (cons_enum m2 End) |
|
353 |
|
|
354 |
let equal cmp m1 m2 = |
|
355 |
let rec equal_aux e1 e2 = |
|
356 |
match e1, e2 with |
|
357 |
| End, End -> |
|
358 |
true |
|
359 |
| End, _ -> |
|
360 |
false |
|
361 |
| _, End -> |
|
362 |
false |
|
363 |
| More (v1, d1, r1, e1), More (v2, d2, r2, e2) -> |
|
364 |
Ord.compare v1 v2 = 0 |
|
365 |
&& cmp d1 d2 |
|
366 |
&& equal_aux (cons_enum r1 e1) (cons_enum r2 e2) |
|
367 |
in |
|
368 |
equal_aux (cons_enum m1 End) (cons_enum m2 End) |
|
369 |
|
|
370 |
let rec cardinal = function |
|
371 |
| Empty -> |
|
372 |
0 |
|
373 |
| Node (l, _, _, r, _) -> |
|
374 |
cardinal l + 1 + cardinal r |
|
375 |
|
|
376 |
let rec bindings_aux accu = function |
|
377 |
| Empty -> |
|
378 |
accu |
|
379 |
| Node (l, v, d, r, _) -> |
|
380 |
bindings_aux ((v, d) :: bindings_aux accu r) l |
|
381 |
|
|
382 |
let bindings s = bindings_aux [] s |
|
383 |
|
|
384 |
let choose = min_binding |
|
337 | 385 |
end |
Also available in: Unified diff
reformatting