Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 829 lines (705 sloc) 22.689 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 (* CF mli *)
19
20 include List
21 exception Empty
22
23 let sprintf = Printf.sprintf
24 let (|>) x f = f x
25 let (@*) f g x = f (g x)
26
27 let get_only_element = function
28 | [x] -> x
29 | _ -> invalid_arg "List.get_only_element"
30
31 let map_right f l = rev_map f (rev l)
32
33 let tail_append l1 l2 = rev_append (rev l1) l2
34
35 let rev_map_append fct l1 l2 =
36 let rec aux acc = function
37 | [] -> acc
38 | hd :: tl ->
39 let hd = fct hd in
40 aux (hd :: acc) tl
41 in
42 aux l2 l1
43
44 let rev_filter_map_append fct l1 l2 =
45 let rec aux acc = function
46 | [] -> acc
47 | hd :: tl -> (
48 match fct hd with
49 | None -> aux acc tl
50 | Some hd -> aux (hd :: acc) tl
51 )
52 in aux l2 l1
53
54 let empty = []
55
56 let is_empty = function
57 | [] -> true
58 | _ -> false
59
60 let rec mem_eq ~eq x = function
61 | [] -> false
62 | a :: l -> eq a x || mem_eq ~eq x l
63
64 let substract l1 l2 =
65 List.rev (fold_left (fun l x -> if mem x l2 then l else x::l) [] l1)
66 let subtract = substract (* backwards-typo compatibility *)
67
68 let substract_eq ~eq l1 l2 =
69 List.rev (fold_left (fun l x -> if mem_eq ~eq x l2 then l else x :: l) [] l1)
70
71 (* subset l1 l2 tests whether the list l1 is a subset of the list l2 *)
72 let subset l1 l2 =
73 List.for_all (fun e -> List.mem e l2) l1
74
75 let subset_eq ~eq l1 l2 =
76 List.for_all (fun e -> List.exists (eq e) l2) l1
77
78 let iter_right f l =
79 let rec aux = function
80 | [] -> ()
81 | hd::tl -> f hd ; aux tl
82 in aux l
83 let iteri f l =
84 ignore (
85 List.fold_left (fun acc x -> let () = f x acc in succ acc) 0 l
86 )
87 let rev_mapi f l =
88 fst (List.fold_left (fun (acc, i) x -> f i x :: acc, i + 1) ([], 0) l)
89 let mapi f l =
90 List.rev (rev_mapi f l)
91
92 let for_alli f l =
93 let rec aux i = function
94 | [] -> true
95 | h :: t -> f i h && aux (i+1) t
96 in
97 aux 0 l
98
99 let map_with_tail f = List.fold_right (fun x y -> (f x)::y)
100 let init n f =
101 let rec aux r i =
102 if i >= 0 then aux ((f i) :: r) (pred i)
103 else r
104 in aux [] (pred n)
105
106 let side_effect_init n f =
107 let rec aux acc i =
108 if i >= n then List.rev acc
109 else
110 aux ((f i) :: acc) (succ i)
111 in
112 aux [] 0
113
114 let rec last = function
115 | [] -> failwith "List.last"
116 | [e] -> e
117 | _e::l -> last l
118
119 let rec take n l =
120 assert (n >= 0);
121 if n = 0 then [] else
122 match l with
123 | [] -> []
124 | e::l -> e :: take (n-1) l
125
126 let rec take_last k l =
127 assert(k>=0);
128 let n=List.length l in
129 let rec aux i l = if i < n-k then aux (i+1) (List.tl l) else l in
130 aux 0 l
131
132 let rec drop n l =
133 assert (n >= 0);
134 if n = 0 then l else
135 match l with
136 | [] -> l
137 | _e::l -> drop (n-1) l
138
139 let rec extract_last = function
140 | [] -> failwith "List.extract_last"
141 | [e] -> [], e
142 | x::xs ->
143 let ys, y = extract_last xs in
144 x::ys, y
145
146 (* example: split_at 2 ["a";"b";"c"] gives ["a";"b"],["c"] *)
147 let split_at n l =
148 let rec aux accu n l =
149 match (n, l) with
150 | 0, _
151 | _, [] -> List.rev accu, l
152 | _, e::l -> aux (e::accu) (n-1) l
153 in
154 assert (n >= 0);
155 aux [] n l
156
157 (* example : split_ats [1;2;3] ["a";"b";"c";"d";"e";"f"] gives [["a"]; ["b";"c"]; ["d";"e";"f"]]*)
158 let split_ats lengths l =
159 let rec aux lengths l acc =
160 match lengths with
161 | [] ->
162 if l = [] then
163 List.rev acc
164 else
165 raise (Invalid_argument "List.split_ats")
166 | n :: lengths_t ->
167 let l1, r = split_at n l in
168 aux lengths_t r (l1 :: acc)
169 in
170 aux lengths l []
171
172 let split_at_sep f l =
173 let rec aux f l acc0 acc1 =
174 match l with
175 | x :: rl -> if f x then (List.rev acc0)::acc1 else aux f rl (x::acc0) acc1
176 | _ -> List.rev acc1
177 in aux f l [] []
178
179 (* example:
180 splice 1 1 [] ["a";"b";"c"] gives ["a";"c"]
181 splice 1 1 ["B"] ["a";"b";"c"] gives ["a";"B";"c"]
182 *)
183 let splice index nb_to_remove elts_to_add l =
184 let beg_to_keep, l = split_at index l in
185 let end_to_keep = drop nb_to_remove l in
186 beg_to_keep @ elts_to_add @ end_to_keep
187
188 let fold_left_i f init l =
189 snd (fold_left (fun (i, acc) x -> (succ i, f acc x i)) (0, init) l)
190
191 let fold_right_i f l init =
192 let len = ref 0 in
193 let l = rev_map (fun e -> incr(len) ; e) l in
194 snd (fold_left (fun (i, acc) x -> (pred i, f x i acc)) (pred (!len), init) l)
195
196 let fold f = function
197 | hd :: tl -> fold_left f hd tl
198 | _ -> raise Empty
199
200 let collect f l =
201 let rec collect_accu f accu = function
202 | [] -> accu
203 | e::l -> collect_accu f (List.rev_append (f e) accu) l
204 in
205 List.rev (collect_accu f [] l)
206
207 let rev_filter f tl =
208 let rec aux accu = function
209 | [] -> accu
210 | hd::tl ->
211 if f hd
212 then aux (hd::accu) tl
213 else aux accu tl
214 in
215 aux [] tl
216
217 let tail_filter f tl = List.rev (rev_filter f tl)
218
219 let to_string f l =
220 let rec aux = function
221 | hd::tl -> sprintf "%s%s" (f hd) (aux tl)
222 | _ -> "" in
223 aux l
224 let print f l =
225 let rec aux = function
226 | [] -> "]"
227 | [hd] -> sprintf "%s]" (f hd)
228 | hd::tl -> sprintf "%s;%s" (f hd) (aux tl) in
229 sprintf "[%s" (aux l)
230 let max, min =
231 let oper op = function
232 | [] -> raise Empty
233 | hd::tl -> fold_left op hd tl
234 in
235 (fun l -> oper max l),
236 (fun l -> oper min l)
237
238 let minmax =
239 let minmax (mi, ma) x = if x < mi then x, ma else if x > ma then mi, x else mi, ma in
240 function
241 | [] -> raise Empty
242 | hd::tl -> fold_left minmax (hd, hd) tl
243
244 let argmax, argmin =
245 let argoper op = function
246 | [] -> raise Empty
247 | hd::tl -> fold_left (fun acc x -> if op x acc then x else acc) hd tl
248 in
249 (fun l -> argoper (>) l),
250 (fun l -> argoper (<) l)
251
252 let remove_all v = filter (fun x -> x<>v)
253 let remove_first v =
254 let rec aux stack = function
255 | [] -> stack
256 | hd :: tl when hd = v -> List.rev stack @ tl
257 | hd :: tl -> aux (hd :: stack) tl
258 in aux []
259
260
261
262 (* ************************************************************************** *)
263 (** {b Descr}: See .mli file for documentation.
264 {b Visibility}: Exported outside this module. *)
265 (* ************************************************************************** *)
266 let remove_first_or_fail_eq ~eq v =
267 let rec aux stack = function
268 | [] -> raise Not_found
269 | hd :: tl when eq hd v -> List.rev stack @ tl
270 | hd :: tl -> aux (hd :: stack) tl
271 in aux []
272
273
274
275 let remove_last l =
276 fst (List.fold_right (
277 fun e (acc, last) ->
278 if last then
279 acc, false
280 else
281 e :: acc, last
282 ) l ([], true))
283
284 let replace v rl =
285 let rec aux acc = function
286 | [] -> rev acc
287 | hd :: tl when hd = v -> aux ((List.rev rl) @ acc) tl
288 | hd :: tl -> aux (hd :: acc) tl
289 in aux []
290
291 let cons e l = e::l
292
293 let uniq ?(cmp = Pervasives.compare) = function
294 | hd :: tl ->
295 let l, _ =
296 List.fold_left (
297 fun ((l, e) as acc) x ->
298 if 0 = cmp x e then acc
299 else (x :: l, x)
300 ) ([hd], hd) tl
301 in
302 List.rev l
303 | [] -> []
304
305 let uniq_unsorted ?(cmp = Pervasives.compare) ?(conflict=(fun _ _ -> ())) l =
306 let l = fold_left (fun acc e ->
307 try
308 let e' = find (fun x -> cmp e x = 0) acc in
309 conflict e e';
310 acc
311 with Not_found -> e :: acc) [] l
312 in
313 rev l
314
315 let rec insert p e l = match p, l with
316 | 0, _ -> e :: l
317 | _n, [] -> raise Empty
318 | _n, (t::q) -> t :: (insert (pred p) e q)
319
320 let insert_sorted ?(cmp=Pervasives.compare) ?(conflict=(fun x y -> [x;y])) x l =
321 let rec aux = function
322 | [] -> [x]
323 | (t::q) as l -> let c = cmp x t in
324 if c < 0 then x::l
325 else if c > 0 then t::(aux q)
326 else (conflict x t)@q
327 in aux l
328
329
330 let filter_and_fold f =
331 let rec aux accu = function
332 | [] -> accu, []
333 | e::l ->
334 let accu, b = f accu e in
335 let accu, l = aux accu l in
336 accu, (if b then e::l else l)
337 in aux
338
339 let filteri f =
340 let rec aux acc pos = function
341 | [] -> List.rev(acc)
342 | x::y -> aux (if f pos x then x::acc else acc) (pos+1) y
343 in
344 aux [] 0
345
346 let flip l =
347 let rec aux accu l =
348 match accu, l with
349 | accu, [] -> accu
350 | [], e::l -> [e]::(aux [] l)
351 | a::accu, e::l -> (e::a)::(aux accu l)
352 in
353 List.fold_left aux [] l
354
355 let combine_opt l1 l2 =
356 try Some (combine l1 l2) with Invalid_argument _ -> None
357
358 let assoc_opt key =
359 let rec aux = function
360 | [] -> None
361 | (k, v)::_ when key = k -> Some v
362 | _::q -> aux q
363 in aux
364
cb74acd [enhance] libbase/List: added assq_opt
Louis Gesbert authored
365 let assq_opt key =
366 let rec aux = function
367 | [] -> None
368 | (k, v)::_ when key == k -> Some v
369 | _::q -> aux q
370 in aux
371
fccc685 Initial open-source release
MLstate authored
372 let find_opt f l =
373 try
374 Some (find f l)
375 with
376 | Not_found -> None
377
378 let find_map f l =
379 let rec aux = function
380 | [] -> None
381 | hd::tl -> (
382 match f hd with
383 | ( Some _ ) as some -> some
384 | None -> aux tl
385 )
386 in aux l
387
388 let findi f =
389 let rec aux i = function
390 | [] -> None
391 | x::_ when f x -> Some i
392 | _::l -> aux (succ i) l
393 in
394 fun l -> aux 0 l
395
396 let find_i f =
397 let rec aux i = function
398 | [] -> None
399 | x::_ when f x -> Some (i, x)
400 | _::l -> aux (succ i) l
401 in
402 fun l -> aux 0 l
403
404 let find_map f tl =
405 let rec aux = function
406 | [] -> None
407 | hd :: tl -> (
408 match f hd with
409 | None ->
410 aux tl
411 | ( Some _ ) as some -> some
412 )
413 in
414 aux tl
415
416 (** memi e l returns the index (position) of the element e *)
417 let memi e l = findi (fun x -> x = e) l
418 let pos_opt = memi
419
420 let filter_map f l =
421 List.fold_right (fun v acc -> match f v with None -> acc | Some v -> v::acc) l []
422
423 let filter_mapi f l =
424 mapi (fun i it -> (i, it) ) l
425 |> filter_map (fun (i, it) -> f i it)
426
427
428 let partition_map f l =
429 let cons_opt o l = Option.default_map l (fun x -> x::l) o in
430 List.fold_right (fun v (acc1, acc2) ->
431 let (o1, o2) = f v in
432 (cons_opt o1 acc1, cons_opt o2 acc2)) l ([], [])
433
434 let get_first_some list arg =
435 let rec aux = function
436 | [] -> None
437 | t::q ->
438 begin
439 match t arg with
440 | None -> aux q
441 | some -> some
442 end
443 in aux list
444
445 let get_first_some_ar2 list arg1 arg2 =
446 let rec aux = function
447 | [] -> None
448 | t::q ->
449 begin
450 match t arg1 arg2 with
451 | None -> aux q
452 | some -> some
453 end
454 in aux list
455
456 (* maping with accu : no tail rec or rev *)
457 let fold_right_map fct list accu =
458 let rec aux = function
459 | [] -> [], accu
460 | t::q ->
461 let tl, accu = aux q in
462 let hd, accu = fct t accu in
463 hd::tl, accu
464 in aux list
465
466
467 (* see the mli for comments on foldl[1] foldr[1] *)
468 let rec foldl f l a = match l with
469 | hd :: tl -> foldl f tl (f hd a)
470 | _ -> a
471
472 let foldl1 f = function
473 | [] -> invalid_arg "List.foldl1: empty list"
474 | e::l -> foldl f l e
475
476
477 let fold_left1 f = function
478 | [] -> invalid_arg "List.fold_left1: empty list"
479 | e::l -> List.fold_left f e l
480
481 let foldr = List.fold_right
482
483 let foldr1 f =
484 let rec aux = function
485 | [] -> invalid_arg "List.foldr1: empty list"
486 | [x] -> x
487 | t::q -> f t (aux q)
488 in aux
489
490 let rec fold_left_snd f acc = function
491 | [] -> acc
492 | (_,x) :: t -> fold_left_snd f (f acc x) t
493
494 let map_stable map list =
495 let equal = ref true in
496 let fct acc elt =
497 let felt = map elt in
498 if elt != felt then equal := false;
499 felt::acc in
500 let flist = List.fold_left fct [] list in
501 if !equal then list else List.rev flist
502
64bea56 [enhance] list: add filter_stable
Mathieu Barbin authored
503 let filter_stable filter list =
504 let equal = ref true in
505 let f acc elt =
506 if filter elt then elt :: acc else (equal := false ; acc)
507 in
508 let acc = List.fold_left f [] list in
509 if !equal then list else List.rev acc
510
5b18026 [enhance] Stdlib: Comments in Standard Library
Arthur Milchior authored
511 (**
512 {[('acc -> 'input -> ('acc * 'output)) -> 'acc -> 'output list -> 'input list -> ('acc * 'output list)]}
513 @param f takes the accumulator and the head of the list to give back the new element
514 of the output list and the new accumulator
515 @param end_ is the end of the output list
516 the result of the mapping is reversed
517 *)
fccc685 Initial open-source release
MLstate authored
518 let fold_left_rev_map_end f acc end_ list =
519 let rec aux acc list = function
520 | [] -> acc, list
521 | h :: t ->
522 let acc, h = f acc h in
523 aux acc (h :: list) t in
524 aux acc end_ list
525
526 let fold_left_rev_map f acc list = fold_left_rev_map_end f acc [] list
5b18026 [enhance] Stdlib: Comments in Standard Library
Arthur Milchior authored
527
528 (**
529 {[('acc -> 'input -> ('acc * 'output)) -> 'acc -> 'output list -> 'input list -> ('acc * 'output list)]}
530 @param f takes the accumulator and the head of the list to give back the new element
531 of the output list and the new accumulator
532 @param rev_beginning is the beginning of the output list in the reverse order
533 *)
fccc685 Initial open-source release
MLstate authored
534 let fold_left_map_init f acc rev_beginning list =
535 let acc, l = fold_left_rev_map_end f acc rev_beginning list in
536 acc, List.rev l
537
538 let fold_left_map f acc list = fold_left_map_init f acc [] list
539
540 let fold_left_map_stable f acc orig_list =
541 let rec aux acc list = function
542 | [] -> acc, orig_list (* if we come here, then all the images were physically
543 * to the original element, so we give back the input list *)
544 | h :: t ->
545 let acc, h' = f acc h in
546 if h == h' then
547 aux acc (h' :: list) t
548 else
549 (* when one equality fails, switching to the usual fold_left_map
550 * because there is no point in doing the other comparisons anymore *)
551 fold_left_map_init f acc (h' :: list) t in
552 aux acc [] orig_list
553
554 let fold_right_map_stable f acc orig_list =
555 let rec aux acc list = function
556 | [] -> acc, orig_list
557 | h :: t ->
558 let acc, h' = f acc h in
559 if h == h' then
560 aux acc (h' :: list) t
561 else
562 fold_left_rev_map_end f acc (h' :: list) t in
563 aux acc [] (List.rev orig_list)
564
565 let fold_left_filter_map fct accu list =
566 let fct (accu, list) elt =
567 let accu, elt = fct accu elt in
568 accu, (match elt with None -> list | Some elt -> elt::list) in
569 let accu, list = List.fold_left fct (accu,[]) list in
570 accu, List.rev list
571
572 (** raises Invalid_argument "fold_left2" *)
573 let fold_left_map2 fct accu list1 list2 =
574 let fct (accu, list) elt1 elt2 =
575 let accu, elt = fct accu elt1 elt2 in
576 accu, elt::list in
577 let accu, list = List.fold_left2 fct (accu,[]) list1 list2 in
578 accu, List.rev list
579
580 let fold_left_collect fct accu list =
581 let fct (accu, list) elt =
582 let accu, elt_list = fct accu elt in
583 accu, List.rev_append elt_list list in
584 let accu, list = List.fold_left fct (accu, []) list in
585 accu, List.rev list
586
587 let fold_left_map_i f init l =
588 let (_, acc), l = fold_left_map
589 (fun (i, acc) x ->
590 let acc, x = f i acc x
591 in ((succ i, acc), x)) (0, init) l
592 in acc, l
593
594 let for_all2_same_length f l1 l2 =
595 List.length l1 = List.length l2 && for_all2 f l1 l2
596
597 (* tail rec *)
598 let rev_concat_map fct =
599 let rec aux accu = function
600 | [] -> accu
601 | e::l -> aux (List.rev_append (fct e) accu) l
602 in aux []
603
604 let concat_map f = rev @* rev_concat_map f
605
606 let rev_concat_map2 fct l1 l2 =
607 let rec aux acc l1 l2 =
608 match l1, l2 with
609 | [], [] -> acc
610 | e1 :: l1, e2 :: l2 -> aux (List.rev_append (fct e1 e2) acc) l1 l2
611 | _ -> invalid_arg "List.rev_concat_map2" in
612 aux [] l1 l2
613 let concat_map2 f l1 l2 = rev (rev_concat_map2 f l1 l2)
614
615 let tail_concat l = (* dont factor l : '_a *)
616 let rec aux accu = function
617 | [] -> List.rev accu
618 | t::q -> aux (List.rev_append t accu) q
619 in aux [] l
620
621 let tail_append_keep_length a b =
622 let rec aux acc i = function
623 | [] -> i, acc
624 | t::q -> aux (t::acc) (succ i) q in
625 let la, a = aux [] 0 a in
626 let lb, ba = aux a 0 b in
627 la, lb, List.rev ba
628
629 let tail_split a =
630 let u, v = List.fold_left (fun (u, v) (x, y) -> x::u, y::v) ([], []) a in
631 List.rev u, List.rev v
632
633 let tail_map f a = List.rev (List.rev_map f a)
634 let tail_map2 f a b = List.rev (List.rev_map2 f a b)
635
636 (* association lists; value map, index map and renaming map *)
637 let vmap f l = List.map (fun (i, v) -> (i, f v)) l
638 let imap f l = List.map (fun (i, _v) -> (i, f i)) l
639 let rmap f l = List.map (fun (i, v) -> (f i, v)) l
640
641 (* association lists, tail version : value map, index map and renaming map *)
642 let tail_vmap f l = tail_map (fun (i, v) -> (i, f v)) l
643 let tail_imap f l = tail_map (fun (i, _v) -> (i, f i)) l
644 let tail_rmap f l = tail_map (fun (i, v) -> (f i, v)) l
645
646 (* applies f on all pairs of the cartesian product l1 * l2 *)
647 let rectangle_map f l1 l2 =
648 if l2 = [] then [] (* speedup *) else
649 let rec aux l1 l2 =
650 match l1 with
651 | [] -> []
652 | h1::t1 -> List.map (f h1) l2 @ aux t1 l2
653 in aux l1 l2
654
655 (* a combinator useful when forall x y. f x y = f y x *)
656 let triangle_map f l1 l2 =
657 if l1 = [] || l2 = [] then [] (* speedup *) else
658 let (l1, l2) =
659 if List.length l1 <= List.length l2
660 then (l1, l2) else (l2, l1) in
661 let rec aux l1 l2 =
662 match l1 with
663 | [] -> []
664 | [h1] -> List.map (f h1) l2
665 | h1::t1 ->
666 match l2 with
667 | [] -> assert false (* because length l1 <= length l2 *)
668 | _h2::t2 -> List.map (f h1) l2 @ aux t1 t2
669 in aux l1 l2
670
671 let make_compare cmp =
672 let rec compare l1 l2 = match l1, l2 with
673 | [], [] -> 0
674 | [], _ -> -1
675 | _, [] -> 1
676 | h1::t1, h2::t2 -> let cmp_h = cmp h1 h2 in
677 if cmp_h <> 0 then cmp_h else compare t1 t2
678 in compare
679
680 let option_like_merge conflict l1 l2 =
681 match l1, l2 with
682 | [], [] -> []
683 | _, [] -> l1
684 | [], _ -> l2
685 | _, _ -> conflict l1 l2
686
687 let choose_random = function
688 | [] -> invalid_arg "List.choose"
689 | l ->
690 let idx = Random.int (length l) in
691 nth l idx
692
693 (** A generic range filtering function, used in db *)
694 let filterbounds (start_opt, len) index l =
695 let rec cut_beg cond =
696 function x::r when cond x -> cut_beg cond r | l -> l in
697 let rec rev_cut_end cond acc =
698 function [] -> acc | x::_ when cond x -> acc | x::r -> rev_cut_end cond (x::acc) r in
699 let rec rev_cut_len n acc =
700 function [] -> acc | x::r -> if n <= 0 then acc else rev_cut_len (n-1) (x::acc) r in
701 if len >= 0 then
702 let l = match start_opt with Some s -> cut_beg (fun x -> index x < s) l | None -> l in
703 if len <> 0 then rev (rev_cut_len len [] l) else l
704 else
705 match start_opt with
706 | Some s -> rev_cut_end (fun x -> index x > s) [] l |> rev_cut_len (0-len) [] |> rev
707 | None -> rev l |> rev_cut_len (- len) [] |> rev
708
709
710
711 (* ************************************************************************** *)
712 (** {b Descr}: Returns the value (second component) associated with the key
713 (first component) equal to [x] in a list of pairs.
714 Raises [Not_found] if there is no value associated with [x] in the list.
715 Equality test is performed with the provided function [eq] instead of the
716 general [=] function. *)
717 (* ************************************************************************** *)
718 let rec assoc_custom_equality ~eq x = function
719 | [] -> raise Not_found
720 | (k, v) :: rem ->
721 if eq k x then v else assoc_custom_equality ~eq x rem
722
c60fe6f [feature] list: assoc_custom_equality_opt
Arthur Milchior authored
723 let rec assoc_custom_equality_opt ~eq x = function
724 | [] -> None
725 | (k, v) :: rem ->
726 if eq k x then Some v else assoc_custom_equality_opt ~eq x rem
727
fccc685 Initial open-source release
MLstate authored
728
729 (* ************************************************************************** *)
730 (** {b Descr}: Transforms a list of triplets into a triplet of lists. *)
731 (* ************************************************************************** *)
732 let rec split3 = function
733 [] -> ([], [], [])
734 | (x,y,z) :: l ->
735 let (rx, ry, rz) = split3 l in (x :: rx, y :: ry, z :: rz)
736
737 module MakeAssoc(S:Map.OrderedType) = struct
738 type 'a t = (S.t * 'a) list
739 let equal x y = S.compare x y = 0
740 let rec find k = function
741 | [] -> raise Not_found
742 | (k',v) :: t ->
743 if equal k k' then v
744 else find k t
745 let rec find_opt k = function
746 | [] -> None
747 | (k',v) :: t ->
748 if equal k k' then Some v
749 else find_opt k t
750 let rec mem k = function
751 | [] -> false
752 | (k',_) :: t -> equal k k' || mem k t
753 let remove k l =
754 let rec aux acc = function
755 | [] -> l
756 | ((k',_) as c) :: t ->
757 if equal k k' then List.rev_append acc t
758 else aux (c :: acc) t in
759 aux [] l
760
761 let sorted_merge l1 l2 =
762 let rec aux acc l1 l2 =
763 match l1, l2 with
764 | [], l
765 | l, [] -> List.rev_append acc l
766 | ((k1,_) as c1) :: t1, ((k2,_) as c2) :: t2 ->
767 let c = S.compare k1 k2 in
768 if c < 0 then
769 aux (c1 :: acc) t1 l2
770 else
771 aux (c2 :: acc) l1 t2 in
772 aux [] l1 l2
773
774 let unique_sorted_merge ~merge l1 l2 =
775 let rec aux acc l1 l2 =
776 match l1, l2 with
777 | [], l
778 | l, [] -> List.rev_append acc l
779 | ((k1,_) as c1) :: t1, ((k2,_) as c2) :: t2 ->
780 let c = S.compare k1 k2 in
781 if c < 0 then
782 aux (c1 :: acc) t1 l2
783 else if c = 0 then (
784 let (k3,_) as r = merge c1 c2 in
785 if not (equal k1 k3) then invalid_arg "BaseList.MakeAssoc.unique_sorted_merge";
786 aux acc (r :: t1) t2
787 ) else
788 aux (c2 :: acc) l1 t2 in
789 aux [] l1 l2
790
791 let sort l =
792 sort (fun (k1,_) (k2,_) -> S.compare k1 k2) l
793 end
794
795 module StringAssoc = MakeAssoc(String)
796
797 let rev_partial_map2 f l1 l2 =
798 let rec aux acc l1 l2 =
799 match l1, l2 with
800 | [], _
801 | _, [] -> acc
802 | h1 :: t1, h2 :: t2 -> aux (f h1 h2 :: acc) t1 t2 in
803 aux [] l1 l2
804 let partial_map2 f l1 l2 = List.rev (rev_partial_map2 f l1 l2)
805
806 let rev_fold_left_partial_map2 f acc l1 l2 =
807 let rec aux acc1 acc2 l1 l2 =
808 match l1, l2 with
809 | [], _
810 | _, [] -> acc1, acc2
811 | h1 :: t1, h2 :: t2 ->
812 let acc1, h = f acc1 h1 h2 in
813 aux acc1 (h :: acc2) t1 t2 in
814 aux acc [] l1 l2
815 let fold_left_partial_map2 f acc l1 l2 =
816 let acc, l = rev_fold_left_partial_map2 f acc l1 l2 in
817 acc, List.rev l
818
819 let filter2 f l1 l2 =
820 let rec aux acc1 acc2 l1 l2 =
821 match l1, l2 with
822 | [], [] -> List.rev acc1, List.rev acc2
823 | h1 :: t1, h2 :: t2 ->
824 if f h1 h2
825 then aux (h1 :: acc1) (h2 :: acc2) t1 t2
826 else aux acc1 acc2 t1 t2
827 | _ -> invalid_arg "List.filter2" in
828 aux [] [] l1 l2
Something went wrong with that request. Please try again.