Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 634 lines (551 sloc) 19.519 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module Set = BaseSet
20
21 (* -- *)
22
23 exception IteratorEnd
24
25 module Make (Ord: OrderedTypeSig.S) : (BaseMapSig.S with type key = Ord.t) =
26 struct
27
28 type key = Ord.t
29
30 type 'a t =
31 | Empty
32 | Node of 'a t * key * 'a * 'a t * int
33
34 let decons = function
35 | Empty -> invalid_arg "Map.decons"
36 | Node (left, key, val_, right, _) -> left, key, val_, right
37
38 let height = function
39 | Empty -> 0
40 | Node(_,_,_,_,h) -> h
41
42 let create l x d r =
43 let hl = height l and hr = height r in
44 Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
45
5b18026 [enhance] Stdlib: Comments in Standard Library
Arthur Milchior authored
46 (*
47 Balance the tree such that the difference between the heights of
48 the two branches is at most one
49 *)
fccc685 Initial open-source release
MLstate authored
50 let bal l x d r =
51 let hl = height l
52 and hr = height r in
53 if hl > hr + 2 then begin
54 match l with
55 | Empty -> assert false
56 | Node(ll, lv, ld, lr, _) ->
57 if height ll >= height lr then
58 create ll lv ld (create lr x d r)
59 else begin
60 match lr with
61 Empty -> assert false
62 | Node(lrl, lrv, lrd, lrr, _)->
63 create (create ll lv ld lrl) lrv lrd (create lrr x d r)
64 end
65 end else if hr > hl + 2 then begin
66 match r with
67 | Empty -> assert false
68 | Node(rl, rv, rd, rr, _) ->
69 if height rr >= height rl then
70 create (create l x d rl) rv rd rr
71 else begin
72 match rl with
73 Empty -> assert false
74 | Node(rll, rlv, rld, rlr, _) ->
75 create (create l x d rll) rlv rld (create rlr rv rd rr)
76 end
77 end else
78 Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
79
80 let empty = Empty
81
82 let is_empty = function Empty -> true | _ -> false
83
84 let singleton x data = Node (Empty, x, data, Empty, 1)
85
86 let rec add x data = function
87 | Empty -> Node (Empty, x, data, Empty, 1)
88 | Node (l, v, d, r, h) ->
89 let c = Ord.compare x v in
90 if c = 0 then Node(l, x, data, r, h)
91 else if c < 0 then bal (add x data l) v d r
92 else bal l v d (add x data r)
93
94 let replace x replace map =
95 let rec aux = function
96 | Empty -> Node (Empty, x, replace None, Empty, 1)
97 | Node (l, v, d, r, h) ->
98 let c = Ord.compare x v in
99 if c = 0 then Node (l, x, replace (Some d), r, h)
100 else if c < 0 then bal (aux l) v d r
101 else bal l v d (aux r)
102 in
103 aux map
104
105 let update key f map =
106 let f = function
107 | None -> raise Not_found
108 | Some a -> f a
109 in
110 replace key f map
111
112 let update_default key f default map =
113 let f = function
114 | None -> default
115 | Some a -> f a
116 in
117 replace key f map
118
119 let rec safe_add x data = function
120 | Empty -> Node (Empty, x, data, Empty, 1)
121 | Node (l, v, d, r, _h) ->
122 let c = Ord.compare x v in
123 if c = 0 then raise (Invalid_argument "Base.Map.safe_add")
124 else if c < 0 then bal (safe_add x data l) v d r
125 else bal l v d (safe_add x data r)
126
127 let rec findi_opt x = function
128 | Empty -> None
129 | Node(l, v, d, r, _) ->
130 let c = Ord.compare x v in
131 if c = 0 then Some (v,d)
132 else findi_opt x (if c < 0 then l else r)
133
134 let find_opt x m = Option.map snd (findi_opt x m)
135
136 (** @raise Not_found. *)
137 let find x m = Option.get_exn (Not_found) (find_opt x m)
138
139 (** @raise Not_found. *)
140 let findi x m = Option.get_exn (Not_found) (findi_opt x m)
141
142 let rec size = function
143 | Empty -> 0
144 | Node (l, _, _, r, _) -> 1 + size l + size r
145
146 (* let random m =
147 let rec aux height = function
148 | Empty -> raise Not_found
149 | Node (Empty, v, d, Empty, _) -> v, d
150 | Node (Empty, v, d, r, _) ->
151
152 | Node (l, v, d, r, _) ->
153 match Random.int height with
154 | 0 -> (v, d)
155 | i when i mod 2 = 0 -> random (pred height)
156 let c = Ord.compare x v in
157 if c = 0 then (v, d)
158 else if c < 0 then
159 if l = Empty then (v, d)
160 else nearest x l
161 else (* c > 0 *)
162 if r = Empty then (v, d)
163 else nearest x r *)
164
165 (* FIXME: slow *)
166 let rec random = function
167 | Empty -> raise Not_found
168 | Node (l, v, d, r, _) ->
169 let sl = size l
170 and sr = size r in
171 if sl = 0 then
172 if sr = 0 or Random.int (sr + 1) = 0 then v, d
173 else random r
174 else if sr = 0 then
175 if sl = 0 or Random.int (sl + 1) = 0 then v, d
176 else random l
177 else
178 match Random.int (sl + sr + 1) with
179 | 0 -> v, d
180 | i -> random (if i mod 2 = 0 then l else r)
181
182 let rec nearest x = function
183 | Empty -> raise Not_found
184 | Node (l, v, d, r, _) ->
185 let c = Ord.compare x v in
186 if c = 0 then (v, d)
187 else if c < 0 then
188 if l = Empty then (v, d)
189 else nearest x l
190 else (* c > 0 *)
191 if r = Empty then (v, d)
192 else nearest x r
193
194 let return = function
195 | Some r -> r
196 | _ -> raise Not_found
197
198 let find_inf x t =
199 let rec aux res = function
200 | Empty -> return res
201 | Node (l, v, d, r, _) ->
202 let c = Ord.compare x v in
203 if c = 0 then (v, d)
204 else if c < 0 then
205 if l = Empty then return res
206 else aux res l
207 else (* c > 0 *)
208 let res = match res with
209 | Some (rv, _rd) when rv < v -> Some (v, d)
210 | None -> Some (v, d)
211 | _ -> res in
212 if r = Empty then return res
213 else aux res r
214 in aux None t
215
216 let find_sup x t =
217 let rec aux res = function
218 | Empty -> return res
219 | Node (l, v, d, r, _) ->
220 let c = Ord.compare x v in
221 if c = 0 then (v, d)
222 else if c < 0 then
223 let res = match res with
224 | Some (rv, _rd) when rv > v -> Some (v, d)
225 | None -> Some (v, d)
226 | _ -> res in
227 if l = Empty then return res
228 else aux res l
229 else (* c > 0 *)
230 if r = Empty then return res
231 else aux res r
232 in aux None t
233
234 let min t =
235 let rec aux = function
236 | Empty -> raise Not_found
237 | Node (Empty, v, d, _, _) -> v, d
238 | Node (l, _, _, _, _) -> aux l
239 in aux t
240
708e865 [feature] Map: Adding the function choose
Arthur Milchior authored
241 let choose = function
242 | Empty -> raise Not_found
243 | Node (_,v,d,_,_) -> v,d
244
fccc685 Initial open-source release
MLstate authored
245 let max t =
246 let rec aux = function
247 | Empty -> raise Not_found
248 | Node (_, v, d, Empty, _) -> v, d
249 | Node (_, _, _, r, _) -> aux r
250 in aux t
251
252 let rec mem x = function
253 | Empty -> false
254 | Node(l, v, _d, r, _) ->
255 let c = Ord.compare x v in
256 (* FIXME : benchmark *)
257 (* if c < 0 then mem x l *)
258 (* else if c > 0 then mem x r *)
259 (* else true *)
260 c = 0 || mem x (if c < 0 then l else r)
261
262 let rec min_binding = function
263 Empty -> raise Not_found
264 | Node(Empty, x, d, _r, _) -> (x, d)
265 | Node(l, _x, _d, _r, _) -> min_binding l
266
267 let rec remove_min_binding = function
268 Empty -> invalid_arg "Map.remove_min_elt"
269 | Node(Empty, _x, _d, r, _) -> r
270 | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
271
272 let _merge t1 t2 =
273 match t1, t2 with
274 | (Empty, t) | (t, Empty) -> t
275 | _ ->
276 let (x, d) = min_binding t2 in
277 bal t1 x d (remove_min_binding t2)
278
279 let rec remove x = function
280 | Empty -> Empty
281 | Node (l, v, d, r, _h) ->
282 let c = Ord.compare x v in
283 if c = 0 then _merge l r
284 else if c < 0 then bal (remove x l) v d r
285 else bal l v d (remove x r)
286
287 let rec iter f = function
288 Empty -> ()
289 | Node(l, v, d, r, _) ->
290 iter f l; f v d; iter f r
291
292 let rec rev_iter f = function
293 Empty -> ()
294 | Node(l, v, d, r, _) ->
295 rev_iter f r; f v d; rev_iter f l
296
297 let rec map f = function
298 Empty -> Empty
299 | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
300
301 let rec mapi f = function
302 Empty -> Empty
303 | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
304
305 let rec fold_map f m acc =
306 match m with
307 | Empty -> (acc, Empty)
308 | Node (l, v, d, r, h) ->
309 let (acc, l) = fold_map f l acc in
310 let (acc, d) = f v d acc in
311 let (acc, r) = fold_map f r acc in
312 (acc, Node (l, v, d, r, h))
313
314 let rec fold f m acc = match m with
315 | Empty -> acc
316 | Node (l, v, d, r, _) -> fold f r (f v d (fold f l acc))
317
318 let fold_range_compare compare f m kmin kmax acc =
319 (* if compare kmin kmax = 1 then *)
320 (* invalid_arg "[Map.fold_range] kmin > kmax"; *)
321 (* Fold until find kmax. *)
322 let rec fold_max m acc = match m with
323 | Empty -> acc
324 | Node (l, k, v, r, _) ->
325 match compare kmax k with
326 | -1 -> aux_range l acc
327 | 0 -> f k v (fold f l acc)
328 | 1 -> fold_max r (f k v (fold f l acc))
329 | x -> invalid_arg
330 (Printf.sprintf
331 "[Map.fold_range_compare] Unexpected result of compare (%d)" x)
332 (* Fold until find kmin. *)
333 and fold_min m acc = match m with
334 | Empty -> acc
335 | Node (l, k, v, r, _) ->
336 match compare kmin k with
337 | -1 -> fold f r (f k v (fold_min l acc))
338 | 0 -> fold f r (f k v acc)
339 | 1 -> aux_range r acc
340 | x -> invalid_arg
341 (Printf.sprintf
342 "[Map.fold_range_compare] Unexpected result of compare (%d)" x)
343 (* Fold in range. *)
344 and aux_range m acc =
345 match m with
346 | Empty -> acc
347 | Node (l, k, v, r, _) ->
348 match compare kmin k, compare kmax k with
349 | -1, 1 -> fold_max r (f k v (fold_min l acc))
350 | -1, 0 -> f k v (fold_min l acc)
351 | -1, -1 -> aux_range l acc
352 | 0, 1 -> fold_max r (f k v acc)
353 | 0, 0 -> f k v acc
354 | 1, 1 -> aux_range r acc
355 | 1, 0 (* Smaller than kmin and equals to kmax!? *)
356 | 1, -1 (* Smaller than kmin and smaller than kmax!? *)
357 | 0, -1 -> (* Equals to kmin and higher to kmax!? *)
358 assert false
359 | x, y -> invalid_arg
360 (Printf.sprintf
361 "[Map.fold_range_compare] Unexpected result of compare (%d, %d)" x y)
362 in aux_range m acc
363
364 let fold_range x = fold_range_compare Ord.compare x
365
366 let fold_length ~start ~length f m acc =
367 (* Different tool functions used depending on the sign of [length],
368 to avoid code duplication. Probably not more readable, though. *)
369 let (cmp, length, pr_l, pr_r) =
370 if length >= 0 then
371 (Ord.compare, length, fst, snd)
372 else
373 ((fun x y -> 0 - Ord.compare x y), 0 - length, snd, fst)
374 in
375 (* [n] is the number of applications of [f] so far *)
376 let rec aux n f m acc =
377 if n = length then (acc, n) else
378 match m with
379 | Empty -> (acc, n)
380 | Node (l, v, d, r, _) ->
381 let l = pr_l (l, r) in
382 let r = pr_r (l, r) in
383 match cmp start v with
384 | -1 ->
385 let (acc, n) = aux n f l acc in
386 if n = length then (acc, n) else
387 let (acc, n) = (f v d acc, n + 1) in
388 aux n f r acc
389 | 0 ->
390 let (acc, n) = (f v d acc, n + 1) in
391 aux n f r acc
392 | 1 ->
393 aux n f r acc
394 | _ -> assert false
395 in
396 let (acc, n) = aux 0 f m acc in
397 assert (n <= length);
398 (* Value of [n] is the number of elements that we managed to gather;
399 it's equal to [length], unless not enough elements in the tree. *)
400 acc
401
402 (* let rec fold2 f m1 m2 acc = match m1, m2 with *)
403 (* | Empty, Empty -> acc *)
404 (* | Node (l, v, d, r, _) -> fold f r (f v d (fold f l acc)) *)
405
406 let rec fold_rev f m acc = match m with
407 | Empty -> acc
408 | Node (l, v, d, r, _) -> fold_rev f l (f v d (fold_rev f r acc))
409
410 let filter_val f t =
411 fold (fun k v acc -> if f v then add k v acc else acc) t empty
412
413 let filter_keys f m =
414 let rec aux = function
415 | Empty -> Empty
416 | Node (l, v, d, r, _h) ->
417 if f v
418 then bal (aux l) v d (aux r)
419 else _merge (aux l) (aux r)
420 in aux m
421
4f74b3d [enhance] baseMap: iteratore are now tail-recursive
Arthur Milchior authored
422 module Iter : (IterSig.S with type +'a element = key * 'a and type +'a structure = 'a t and type +'a t = ((key *'a ) * 'a t) list) =
fccc685 Initial open-source release
MLstate authored
423 struct
424 type 'a structure = 'a t
425 type 'a element = key * 'a
426 type 'a t = ('a element * 'a structure) list
427
4f74b3d [enhance] baseMap: iteratore are now tail-recursive
Arthur Milchior authored
428 let rec aux_make acc= function
429 | Empty -> acc
430 | Node (l, v, d, r, _) ->
431 let acc=((v,d),r)::acc in
432 aux_make acc l
433
434 let make m = aux_make [] m
fccc685 Initial open-source release
MLstate authored
435 (* let make_iterator m = let rec aux = function | Empty ->
436 [] | Node (l, v, d, r, _) -> (v, d, r) :: aux l in List.rev (aux
437 m) *)
438 let get = function
439 | ((v, d), _) :: _ -> v, d
440 | _ -> raise IteratorEnd
441 let next = function
442 | (_, Empty) :: tl -> tl
4f74b3d [enhance] baseMap: iteratore are now tail-recursive
Arthur Milchior authored
443 | (_, r) :: tl -> aux_make tl r
fccc685 Initial open-source release
MLstate authored
444 | _ -> raise IteratorEnd
445 let at_end i = i = []
446
447 (* TODO change failwith to raise NotImplemented *)
448 let remaining _i = failwith ("NotImplemented BaseMap.Make.Iter.remaining")
449 end
450
2258415 [feature] Map: adding fold_map_2
Arthur Milchior authored
451 let rec fold_map2 f m m' acc =
452 let iter' = Iter.make m' in
453 (* the result of the map, the accumulator and the iterator*)
454 let rec aux iter acc = function
455 | Empty -> Empty, acc, iter
456 | Node (l, v, d, r, h) ->
457 let l, acc, iter = aux iter acc l in
458 let () = if Iter.at_end iter then invalid_arg "baseMap.fold_map2: not enough element in second map" in
459 let v',e = Iter.get iter in
460 let () = if not (v'=v) then invalid_arg "baseMap.fold_map2: map with different elements" in
461 let iter = Iter.next iter in
462 let acc, e = f v d e acc in
463 let r, acc, iter = aux iter acc r in
464 let m = Node (l, v, e, r, h) in
465 m, acc, iter
466 in
467 let m, result, iter'=aux iter' acc m in
468 if Iter.at_end iter' then result, m
469 else invalid_arg "baseMap.fold_map2 not enough element in first map"
470
fccc685 Initial open-source release
MLstate authored
471 module RevIter : (IterSig.S with type +'a element = key * 'a and type +'a structure = 'a t) =
472 struct
473 type 'a structure = 'a t
474 type 'a element = key * 'a
475 type 'a t = ('a structure * 'a element ) list
476
477 let rec make = function
478 | Empty -> []
479 | Node (l, v, d, r, _) -> make r @ [l, (v, d)]
480 (* let make_iterator m = let rec aux = function | Empty ->
481 [] | Node (l, v, d, r, _) -> (v, d, r) :: aux l in List.rev (aux
482 m) *)
483 let get = function
484 | (_, (v, d)) :: _ -> v, d
485 | _ -> raise IteratorEnd
486 let next = function
487 | (Empty, _) :: tl -> tl
488 | (r, _) :: tl -> make r @ tl
489 | _ -> raise IteratorEnd
490 let at_end i = i = []
491
492 (* TODO change failwith to raise NotImplemented *)
493 let remaining _i = failwith ("NotImplemented BaseMap.Make.Iter.remaining")
494 end
495
496 type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
497
498 let rec cons_enum m e =
499 match m with
500 Empty -> e
501 | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
502
503 let compare cmp m1 m2 =
504 let rec compare_aux e1 e2 =
505 match (e1, e2) with
506 (End, End) -> 0
507 | (End, _) -> -1
508 | (_, End) -> 1
509 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
510 let c = Ord.compare v1 v2 in
511 if c <> 0 then c else
512 let c = cmp d1 d2 in
513 if c <> 0 then c else
514 compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
515 in compare_aux (cons_enum m1 End) (cons_enum m2 End)
516
517 let equal cmp m1 m2 =
518 let rec equal_aux e1 e2 =
519 match (e1, e2) with
520 (End, End) -> true
521 | (End, _) -> false
522 | (_, End) -> false
523 | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
524 Ord.compare v1 v2 = 0 && cmp d1 d2 &&
525 equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
526 in equal_aux (cons_enum m1 End) (cons_enum m2 End)
527
528 let from_list l = List.fold_left (fun acc (k, v) -> add k v acc) empty l
529
530 let fold_assoc k v acc = (k, v) :: acc
531
532 let to_list t = fold fold_assoc t []
533 let keys t = fold (fun k _ acc -> k :: acc) t []
534 let elts t = fold (fun _ el acc -> el :: acc) t []
535
536 let ordered_list t = fold_rev fold_assoc t []
537 let rev_ordered_list t = fold fold_assoc t []
538
539 let merge_i f m1 m2 = (* warning: [f] may be not commutative! *)
540 let add_merge x y acc =
541 add x (
542 match find_opt x acc with
543 | Some v -> f x y v
544 | _ -> y
545 ) acc
546 in
547 let add_merge2 x y acc =
548 add x (
549 match find_opt x acc with
550 | Some v -> f x v y
551 | _ -> y
552 ) acc
553 in
554 if height m1 <= height m2 then
555 fold add_merge m1 m2
556 else
557 fold add_merge2 m2 m1
558
559 let merge f m1 m2 = merge_i (fun _ x y -> f x y) m1 m2
560
561 let safe_merge m1 m2 =
562 let m1, m2 = if height m1 <= height m2 then m1, m2 else m2, m1 in
563 try fold safe_add m1 m2 with
564 | Invalid_argument "Base.Map.safe_add" ->
565 raise (Invalid_argument "Base.Map.safe_merge")
566
567 (* Heritage of old unused functions *)
568 let of_set f s =
569 let module S = Set.Make(Ord) in
570 S.fold (fun x acc -> add x (f x) acc) s empty
571
572 let incr ?(step=1) k m =
573 add k ((Option.default 0 (find_opt k m)) + step) m
574
575 let rename f m =
576 fold (fun k elt acc -> add (f k) elt acc) m empty
577
578 (* cf doc *)
579 let pp sep ppe fmt t =
580 let fiter elt val_ =
581 ppe fmt elt val_ ;
582 Format.fprintf fmt sep
583 in
584 iter fiter t
585
586 let compare_key = Ord.compare
587
588 let diff map1 map2 =
589 fold (fun k v acc ->
590 if mem k map2 then
591 acc
592 else
593 add k v acc
594 ) map1 empty
595 let diff2 map1 map2 map3 =
596 fold (fun k v acc ->
597 if mem k map2 && not (mem k map3) then
598 acc
599 else
600 add k v acc
601 ) map1 empty
602
e74f6b5 [feature] libbase: choose_opt in Maps and Sets
Arthur Milchior authored
603 let rec choose_opt = function
604 | Empty -> None
605 | Node(_, k, v, _r, _) -> Some (k, v)
606
645f07a [feature] libbase: Taking an element to show the difference between two...
Arthur Milchior authored
607 let example_diff s1 s2 =
608 let diff_ = diff s1 s2 in
609 match choose_opt diff_ with
610 | Some elt -> Some elt
611 | None ->
612 let diff = diff s2 s1 in
613 match choose_opt diff with
614 | Some elt -> Some elt
615 | None -> None
616
fccc685 Initial open-source release
MLstate authored
617 let from_sorted_array keys vals =
618 let len_keys = Array.length keys in
619 let len_vals = Array.length vals in
620 if len_keys <> len_vals then assert false ;
621 let rec aux left right =
622 if left > right
623 then Empty
624 else
625 let midle = (left + right) lsr 1 in
626 let left_tree = aux left (pred midle) in
627 let right_tree = aux (succ midle) right in
628 let key = Array.unsafe_get keys midle in
629 let value = Array.unsafe_get vals midle in
630 create left_tree key value right_tree
631 in
632 aux 0 (pred len_keys)
633 end
Something went wrong with that request. Please try again.