summaryrefslogtreecommitdiffstats
path: root/perl_checker.src/common.ml
diff options
context:
space:
mode:
Diffstat (limited to 'perl_checker.src/common.ml')
-rw-r--r--perl_checker.src/common.ml798
1 files changed, 798 insertions, 0 deletions
diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
new file mode 100644
index 0000000..4b33f8f
--- /dev/null
+++ b/perl_checker.src/common.ml
@@ -0,0 +1,798 @@
+open Stack
+open List
+
+exception Found
+exception Not_comparable
+exception GraphSort_circular_deps
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+type ('a, 'b) or_option = Or_some of 'a | Or_error of 'b
+
+let bpos = "",-1,-1
+
+let norm (a,b) = if a = -1 then b else a
+let unipos (s,a,b) (s2,c,d) =
+ if (a,b) = (-1,-1) then s2,c,d else
+ if (c,d) = (-1,-1) then s,a,b else
+ if s <> s2 then bpos else s, min (norm(a,c)) (norm(c,a)), max (norm(b,d)) (norm(d,b))
+
+let uniposl l = match l with
+ | [] -> bpos
+ | e::l -> fold_left unipos e l
+
+(**********************************************************************************)
+
+let internal_error s = failwith ("internal error: " ^ s)
+
+let id x = x
+let double a = a,a
+let swap (x,y) = (y,x)
+let safe_tl l = try tl l with _ -> []
+
+let o f g x = f (g x)
+let curry f x y = f (x,y)
+let uncurry f (x, y) = f x y
+
+let is_int n = ceil n = n
+
+let uncons = function
+ | [] -> failwith "uncons"
+ | e::l -> e,l
+
+let has_env var =
+ try
+ let _ = Sys.getenv var in true
+ with Not_found -> false
+
+let some = function Some e -> e | None -> failwith "some"
+
+let some_or = function
+ | None -> id
+ | Some e -> fun _ -> e
+
+let option2l = function
+ | None -> []
+ | Some e -> [e]
+
+let prefer_some f a b =
+ match a, b with
+ | Some a, Some b -> Some (f a b)
+ | None, _ -> b
+ | _, None -> a
+
+let rec collect_accu f accu = function
+ | [] -> accu
+ | e::l -> collect_accu f (rev_append (f e) accu) l
+
+let collect f l = rev (collect_accu f [] l)
+
+let merge_some merge a b =
+ match a,b with
+ | None, None -> None
+ | _, None -> a
+ | None, _ -> b
+ | Some(a), Some(b) -> Some(merge a b)
+
+let rec uniq = function
+ | [] -> []
+ | e::l -> if mem e l then uniq l else e :: uniq l
+
+let rec uniq_ eq = function
+ | [] -> []
+ | e::l ->
+ try
+ let _ = find (eq e) l in
+ uniq_ eq l
+ with Not_found -> e :: uniq_ eq l
+
+let rec non_uniq = function
+ | [] -> []
+ | e::l -> if mem e l then e :: non_uniq l else non_uniq l
+
+let rec member_ eq e = function
+ | [] -> false
+ | e'::l -> if eq e e' then true else member_ eq e l
+
+let rec find_some p = function
+ | [] -> raise Not_found
+ | x :: l ->
+ match p x with
+ | Some v -> v
+ | None -> find_some p l
+
+let fold_left1 f = function
+ | [] -> failwith "fold_left1"
+ | e :: l -> fold_left f e l
+
+let find_index e l =
+ let rec find_index_ i = function
+ | [] -> raise Not_found
+ | e'::l -> if e=e' then i else find_index_ (i+1) l
+ in
+ find_index_ 0 l
+
+let rec find_some_ p = function
+ | [] -> None
+ | x :: l ->
+ match p x with
+ | Some v -> Some v
+ | None -> find_some_ p l
+
+let rec fpartition p l =
+ let rec part yes no = function
+ | [] -> (rev yes, rev no)
+ | x :: l ->
+ (match p x with
+ | None -> part yes (x :: no) l
+ | Some v -> part (v :: yes) no l) in
+ part [] [] l
+
+let partition_either f l =
+ let rec part_either left right = function
+ | [] -> (rev left, rev right)
+ | x :: l ->
+ (match f x with
+ | Left e -> part_either (e :: left) right l
+ | Right e -> part_either left (e :: right) l) in
+ part_either [] [] l
+
+let rec keep_best f =
+ let rec partition e = function
+ | [] -> e, []
+ | e' :: l ->
+ match f(e,e') with
+ | None -> let (e'', l') = partition e l in e'', e' :: l'
+ | Some e'' -> partition e'' l
+ in function
+ | [] -> []
+ | e::l ->
+ let (e', l') = partition e l in
+ e' :: keep_best f l'
+
+let rec keep_bests f l =
+ let rec once e unchanged = function
+ | [] -> None
+ | e' :: l ->
+ match f(e,e') with
+ | None -> once e (e' :: unchanged) l
+ | Some e'' -> Some(e'', unchanged @ l)
+ in
+ let rec as_many_as_possible e l =
+ match once e [] l with
+ | None -> None
+ | Some(e', l') -> Some(some_or (as_many_as_possible e' l') (e', l'))
+ in
+ let rec try_with e l_done l_next =
+ match as_many_as_possible e l_next with
+ | None -> try_with_next (e :: l_done) l_next
+ | Some(e2, l_next2) ->
+ match as_many_as_possible e2 l_done with
+ | None -> try_with_next (e2 :: l_done) l_next2
+ | Some(e3, l_done2) -> try_with e3 l_done2 l_next2
+ and try_with_next l_done = function
+ | [] -> rev l_done
+ | e::l_next -> try_with e l_done l_next
+ in
+ try_with_next [] l
+
+let rec fold_right1 f = function
+ | [] -> failwith "fold_right1"
+ | [e] -> e
+ | e::l -> f e (fold_right1 f l)
+
+let rec for_all2_ p l1 l2 =
+ match (l1, l2) with
+ ([], []) -> true
+ | (a1::l1, a2::l2) -> p a1 a2 && for_all2_ p l1 l2
+ | (_, _) -> false
+
+let maxl l = fold_right1 max l
+
+let rec stack2list s =
+ let l = ref [] in
+ Stack.iter (fun e -> l := e :: !l) s ;
+ !l
+
+let rec fix_point f p =
+ let p' = f p in
+ if p = p' then p else fix_point f p'
+
+let rec fix_point_withenv f env p =
+ let p', env' = f env p in
+ if p = p' then (p, env') else fix_point_withenv f env' p'
+
+let rec fix_point_ nb f p =
+ let p' = f p in
+ if p = p' then p, nb else fix_point_ (nb+1) f p'
+
+(*
+let rec lfix_point f e =
+ let e' = f(e) in
+ if e = e' then e :: lfix_point f e' else [e]
+*)
+
+let do0_withenv doit f env l =
+ let r_env = ref env in
+ doit (fun e -> r_env := f !r_env e) l ;
+ !r_env
+
+let do0_withenv2 doit f env l =
+ let r_env = ref env in
+ doit (fun e e' -> r_env := f !r_env e e') l ;
+ !r_env
+
+let do_withenv doit f env l =
+ let r_env = ref env in
+ let l' = doit (fun e ->
+ let e', env' = f !r_env e in
+ r_env := env' ; e'
+ ) l in
+ l', !r_env
+
+let do2_withenv doit f env l1 l2 =
+ let r_env = ref env in
+ let l' = doit (fun e1 e2 ->
+ let e', env' = f !r_env e1 e2 in
+ r_env := env' ; e'
+ ) l1 l2 in
+ l', !r_env
+
+let do_collect doit f l1 =
+ let l = ref [] in
+ doit (fun i t -> l := f i t @ !l) l1 ;
+ !l
+
+let map_withitself f l =
+ let rec map_withitself_ done_ = function
+ | [] -> done_
+ | e :: l ->
+ let e' = f (done_ @ e :: l) e in
+ map_withitself_ (done_ @ [ e' ]) l
+ in map_withitself_ [] l
+
+let map_t2 f (x,y) = f x, f y
+let map_t3 f (x,y,z) = f x, f y, f z
+let map_option f = function
+ | Some e -> Some (f e)
+ | None -> None
+let map_optionoption f = function
+ | Some e -> f e
+ | None -> None
+let t2_option2option_t2 = function
+ | (Some x, Some y) -> Some(x,y)
+ | _ -> None
+let rec l_option2option_l = function
+ | [] -> Some []
+ | None :: _l -> None
+ | Some e :: l -> map_option (fun l -> e :: l) (l_option2option_l l)
+let map_option_env f (e, env) = map_option f e, env
+
+let if_some bool val_ = if bool then Some val_ else None
+
+let rec fold_left_option f val_ = function
+ | [] -> Some val_
+ | e::l ->
+ match f val_ e with
+ | None -> None
+ | Some val_' -> fold_left_option f val_' l
+
+let collect_some_withenv f env l =
+ let rec collect accu env = function
+ | [] -> rev accu, env
+ | e::l ->
+ let e', env' = f env e in
+ let accu' =
+ match e' with
+ | Some e' -> e'::accu
+ | None -> accu in
+ collect accu' env' l
+ in collect [] env l
+
+let for_all_option_withenv remap f env l =
+ let rec for_all env accu = function
+ | [] -> Some(remap (rev accu)), env
+ | e::l ->
+ (match f env e with
+ | None, env' -> None, env'
+ | Some e', env' -> for_all env' (e' :: accu) l)
+ in
+ for_all env [] l
+
+let for_all2_option_withenv remap f env la lb =
+ let rec for_all env accu = function
+ | [], [] -> Some(remap (rev accu)), env
+ | a::la, b::lb ->
+ (match f env a b with
+ | None, env' -> None, env'
+ | Some ab, env' -> for_all env' (ab :: accu) (la, lb))
+ | _ -> None, env
+ in
+ for_all env [] (la, lb)
+
+let map_or_option f = function
+ | Or_some e -> Or_some (f e)
+ | Or_error err -> Or_error err
+
+let map_index f l =
+ let rec map_ n = function
+ | [] -> []
+ | e::l -> f e n :: map_ (n+1) l
+ in map_ 0 l
+
+let filter_index f l =
+ let rec filter_ n = function
+ | [] -> []
+ | e::l ->
+ let l' = filter_ (n+1) l in
+ if f e n then e :: l' else l'
+ in filter_ 0 l
+
+let iter_index f l =
+ let rec iter_ n = function
+ | [] -> ()
+ | e::l -> f e n ; iter_ (n+1) l
+ in iter_ 0 l
+
+let map_fst f (x, y) = f x, y
+let map_snd f (x, y) = x, f y
+
+let map_withenv f env e = do_withenv map f env e
+let find_withenv f env e = do_withenv find f env e
+let filter_withenv f env e = do_withenv filter f env e
+let exists_withenv f env e = do_withenv exists f env e
+let map_t2_withenv f env e = do_withenv map_t2 f env e
+let for_all_withenv f env e = do_withenv for_all f env e
+let collect_withenv f env e = do_withenv collect f env e
+let partition_either_withenv f env e = do_withenv partition_either f env e
+
+let map2_withenv f env l1 l2 = do2_withenv map2 f env l1 l2
+let for_all2_withenv f env l1 l2 = do2_withenv for_all2 f env l1 l2
+
+let rec take n l =
+ if n = 0 then []
+ else match l with
+ | [] -> raise Not_found
+ | e::l -> e :: take (n-1) l
+let last_n n l = rev (take n (rev l))
+let last l = hd (last_n 1 l)
+
+let rec skipfirst e = function
+ | [] -> []
+ | e'::l when e = e' -> skipfirst e l
+ | l -> l
+
+let rec removelast = function
+ | [] -> failwith "removelast"
+ | [_] -> []
+ | e::l -> e :: removelast l
+
+let rec split_last l =
+ let rec spl accu = function
+ | [] -> failwith "split_last"
+ | [e] -> rev accu, e
+ | e::l -> spl (e :: accu) l
+ in spl [] l
+
+let iter_assoc_val f l = iter (fun (_,v) -> f v) l
+let map_assoc_val f l = map (fun (k,v) -> k, f v) l
+
+let assoc_or_fail e l =
+ try assoc e l with Not_found -> failwith "assoc failed"
+
+let assoc_has_key e l =
+ try let _ = assoc e l in true with Not_found -> false
+
+let assoc_by is_same e l =
+ find_some (fun (a,b) -> if is_same e a then Some b else None) l
+
+let rec update_assoc_by is_same f e = function
+ | [] -> raise Not_found
+ | (a,b) :: l when is_same e a -> (a, f b) :: l
+ | (a,b) :: l -> (a,b) :: update_assoc_by is_same f e l
+
+let update_assoc f e = update_assoc_by (=) f e
+
+let rec update_assoc_by_with_default default is_same f e = function
+ | [] -> [ e, f default ]
+ | (a,b) :: l when is_same e a -> (a, f b) :: l
+ | (a,b) :: l -> (a,b) :: update_assoc_by_with_default default is_same f e l
+
+let update_all_assoc_by is_same f e l =
+ map (fun (a,b) -> a, if is_same e a then f b else b) l
+
+let rec rassoc e = function
+ | [] -> raise Not_found
+ | (k,v) :: l -> if e = v then k else rassoc e l
+
+let rec all_assoc e = function
+ | [] -> []
+ | (e',v) :: l when e=e' -> v :: all_assoc e l
+ | _ :: l -> all_assoc e l
+
+let rec all_assoc_by is_same e = function
+ | [] -> []
+ | (e',v) :: l when is_same e e' -> v :: all_assoc_by is_same e l
+ | _ :: l -> all_assoc_by is_same e l
+
+let prepare_want_all_assoc l =
+ map (fun n -> n, uniq (all_assoc n l)) (uniq (map fst l))
+
+let prepare_want_all_assoc_by is_same l =
+ map (fun n -> n, uniq_ is_same (all_assoc_by is_same n l)) (uniq_ is_same (map fst l))
+
+let prepare_want_all_assoc_by_ is_same_a is_same_b l =
+ map (fun n -> n, uniq_ is_same_b (all_assoc_by is_same_a n l)) (uniq_ is_same_a (map fst l))
+
+let rec count_uniq = function
+ | [] -> []
+ | e::l ->
+ let has, l' = partition ((=) e) l in
+ (e, length has + 1) :: count_uniq l'
+
+let rec repeat e = function
+ | 0 -> []
+ | n -> e :: repeat e (n-1)
+
+let rec inits = function
+ | [] -> [[]]
+ | e::l -> [] :: map (fun l -> e::l) (inits l)
+let rec tails = function
+ | [] -> [[]]
+ | (_::xs) as xxs -> xxs :: tails xs
+
+let apply f x = f x;;
+
+let rec map3 f l1 l2 l3 =
+ match (l1, l2, l3) with
+ ([], [], []) -> []
+ | (a1::l1, a2::l2, a3::l3) -> let r = f a1 a2 a3 in r :: map3 f l1 l2 l3
+ | (_, _, _) -> invalid_arg "map3"
+
+let filter2 f l1 l2 =
+ split (filter f (combine l1 l2))
+
+let break_at f l =
+ let rec b l1 = function
+ | [] -> l1, []
+ | e::l2 -> if f e then (l1, e :: l2) else b (l1 @ [e]) l2
+ in b [] l
+let break v l = break_at ((=) v) l
+
+(* break_at_indice 0 [1;2] gives [], [1;2]
+ break_at_indice 1 [1;2] gives [1], [2]
+ *)
+let rec break_at_indice i l =
+ if i = 0 then [], l else
+ match l with
+ | [] -> raise Not_found
+ | e::l2 ->
+ let a, b = break_at_indice (i-1) l2 in
+ e::a, b
+
+let rev_nth e l =
+ let rec rev_nth' i = function
+ | [] -> raise Not_found
+ | e'::_ when e'=e -> i
+ | _::l -> rev_nth' (i+1) l
+ in rev_nth' 0 l
+
+let rec getset_nth l i f =
+ match l, i with
+ | e::l', 0 -> f e :: l'
+ | [], _ -> failwith "getset_nth"
+ | e::l', _ -> e :: getset_nth l' (i - 1) f
+
+let set_nth l i v = getset_nth l i (fun _ -> v)
+
+let adjustModDown m n = n - (n mod m)
+let adjustModUp m n = adjustModDown m (n + m - 1)
+
+
+let hashtbl_set h k v =
+ Hashtbl.remove h k;
+ Hashtbl.add h k v
+
+let hashtbl_find f h =
+ let r = ref None in
+ Hashtbl.iter (fun v c -> if f v c then r := Some v) h ;
+ match !r with
+ | Some v -> v
+ | None -> raise Not_found
+
+let hashtbl_filter f h =
+ Hashtbl.iter (fun v c -> hashtbl_set h v (f v c)) h
+
+let array_shift a = Array.sub a 1 (Array.length a - 1)
+let array_last_n n a =
+ let len = Array.length a in
+ Array.sub a (len - n) n
+
+let array_collect f a = Array.fold_left (fun l e -> f e @ l) [] a
+
+let rec lvector_product =
+ let rec vector_product a b = match a with
+ | [] -> []
+ | e::l -> map (fun e' -> e :: e') b :: vector_product l b
+ in function
+ | [] -> []
+ | [e] -> map (fun e -> [e]) e
+ | e::l -> flatten (vector_product e (lvector_product l))
+
+let vector_product2 a b =
+ map (function
+ | [a;b] -> a,b
+ | _ -> failwith "vector_product2"
+ ) (lvector_product [ a ; b ])
+
+let rec transpose = function
+ | [] :: _ -> []
+ | ll ->
+ let l, ll' = split (map (function e::l -> e,l | _ -> raise Not_found) ll) in
+ l :: transpose ll'
+
+let rec range min max =
+ if min >= max then [] else min :: range (min + 1) max
+
+let rec filter_some_with f = function
+ | [] -> []
+ | e :: l ->
+ match f e with
+ | None -> filter_some_with f l
+ | Some e' -> e' :: filter_some_with f l
+
+let rec filter_some = function
+ | [] -> []
+ | None :: l -> filter_some l
+ | Some e :: l -> e :: filter_some l
+
+let rec difference l = function
+ | [] -> l
+ | e::l' -> difference (filter ((<>) e) l) l'
+
+let rec difference_ eq l = function
+ | [] -> l
+ | e::l' ->
+ let l2 = filter (fun e' -> not (eq e e')) l in
+ difference_ eq l2 l'
+
+let intersection_by is_same l1 l2 = filter (fun e -> exists (is_same e) l2) l1
+
+let intersection_and_differences eq l1 l2 =
+ let rec both inter l2_only = function
+ | [], l2 -> inter, [], rev l2_only @ l2
+ | l1, [] -> inter, l1, rev l2_only
+ | l1, e2 :: l2' ->
+ match partition (eq e2) l1 with
+ | [], _ -> both inter (e2 :: l2_only) (l1, l2')
+ | _, l1' -> both (e2 :: inter) l2_only (l1', l2')
+ in both [] [] (l1, l2)
+
+let rec triangularize = function
+ | [] -> []
+ | e::l -> (e,l) :: triangularize l
+
+let diagonalize l =
+ map_index (fun a i ->
+ a, filter_index (fun _ j -> i <> j) l
+ ) l
+
+let rec list_of_nonempty_sublists = function
+ | [] -> []
+ | e :: l ->
+ let l' = list_of_nonempty_sublists l in
+ [e] :: l' @ map (fun l -> e :: l) l'
+
+let rec graph_is_sorted_by eq = function
+ | [] -> true
+ | (_,deps) :: l ->
+ for_all (fun e -> try let _ = assoc_by eq e l in false with Not_found -> true) deps && graph_is_sorted_by eq l
+
+let graph_closure_by eq graph =
+ let err = ref None in
+ try
+ let graph_rev = collect (fun (i, l) -> map (fun e -> (e, i)) l) graph in
+ let bothway = map (fun (i,l) -> i, (l, all_assoc_by eq i graph_rev)) graph in
+ let closed = fold_left (fun graph j ->
+ let next, prev = assoc_by eq j graph in
+ let graph2 = fold_left (fun graph i ->
+ if member_ eq i next then (err := Some(j,i); raise GraphSort_circular_deps) else
+ update_assoc_by eq (fun (i_next,i_prev) -> i_next @ next, i_prev) i graph
+ ) graph (filter (fun a -> not (eq a j)) prev) in
+ let graph3 = fold_left (fun graph k ->
+ if member_ eq k prev then (err := Some(j,k); raise GraphSort_circular_deps) else
+ update_assoc_by eq (fun (k_next,k_prev) -> k_next, k_prev @ prev) k graph
+ ) graph2 (filter (fun a -> not (eq a j)) next) in
+ graph3
+ ) bothway (map fst bothway) in
+ Or_some (map (fun (e,(next,_)) -> e, uniq_ eq next) closed)
+ with GraphSort_circular_deps ->
+ Or_error (some !err)
+
+let rec graph_sort_by eq l =
+ let cmp (_, deps_a) (b, _) = if member_ eq b deps_a then 1 else -1 in
+ let rec sort_it = function
+ | [] -> []
+ | [e] -> [e]
+ | e::l ->
+ let l' = sort_it l in
+ let gt, lt = break_at (fun ((_, deps) as e') -> deps = [] or cmp e e' = 1) l' in
+ gt @ [e] @ lt
+ in
+ map_or_option (fun l' ->
+ let l_sorted = rev (sort_it l') in
+ if not (graph_is_sorted_by eq l_sorted) then internal_error "graph_sort failed" else
+ l_sorted
+ ) (graph_closure_by eq l)
+
+let int_sort l = sort (fun a b -> a - b) l
+
+let str_begins_with s prefix =
+ String.sub s 0 (min (String.length s) (String.length prefix)) = prefix
+
+let rec str_contains s1 s2 =
+ match s1 with
+ | "" -> false
+ | _ ->
+ if str_begins_with s1 s2 then true
+ else str_contains (String.sub s1 1 (String.length s1 - 1)) s2
+
+let str_ends_with s suffix =
+ let len = min (String.length s) (String.length suffix) in
+ String.sub s (String.length s - len) len = suffix
+
+let chop = function
+ | "" -> ""
+ | s -> String.sub s 0 (String.length s - 1)
+
+let chomps s =
+ let i = ref (String.length s - 1) in
+ while !i >= 0 && (s.[!i] = ' ' || s.[!i] = '\t') do decr i done ;
+ String.sub s 0 (!i+1)
+
+let skip_n_char_ beg end_ s =
+ String.sub s beg (String.length s - beg - end_)
+let skip_n_char n s = skip_n_char_ n 0 s
+
+let rec explode_string = function
+ | "" -> []
+ | s -> (String.get s 0) :: explode_string (String.sub s 1 (String.length s - 1))
+
+let is_uppercase c = Char.lowercase c <> c
+let is_lowercase c = Char.uppercase c <> c
+
+let starts_with_non_lowercase s = s <> "" && s.[0] <> '_' && not (is_lowercase s.[0])
+
+let get_package_name s =
+ try Some (String.sub s 0 (String.rindex s ':' - 1)) with Not_found -> None
+
+let split_at_two_colons s =
+ let i_fq = String.rindex s ':' in
+ String.sub s 0 (i_fq - 1), skip_n_char (i_fq + 1) s
+
+let to_CamelCase s_ =
+ let l = ref [] in
+ let s = String.copy s_ in
+ for i = 1 to String.length s - 1 do
+ if is_uppercase (String.unsafe_get s i) && is_lowercase (String.unsafe_get s (i-1)) then (
+ String.set s i (Char.lowercase (String.get s i)) ;
+ l := i :: !l
+ )
+ done ;
+ if !l = [] then None else
+ let offset, s' = fold_left (fun (offset, s') i ->
+ i, s' ^ String.sub s offset (i-offset) ^ "_"
+ ) (0, "") (rev !l) in
+ Some (s' ^ String.sub s offset (String.length s - offset))
+
+let (string_of_ref : 'a ref -> string) = fun r ->
+ Printf.sprintf "0x%x" (Obj.magic r : int)
+
+let is_int n = n = floor n
+
+(* total order *)
+let rec compare_lists cmp l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | [], _ -> -1
+ | _, [] -> 1
+ | e1::l1, e2::l2 ->
+ match cmp e1 e2 with
+ | 0 -> compare_lists cmp l1 l2
+ | v -> v
+
+let compare_best a b =
+ match a, b with
+ | 0, 0 -> 0
+ | 1, 1 | 1, 0 | 0, 1 -> 1
+ | -1, -1 | -1, 0 | 0, -1 -> -1
+ | 1, -1 | -1, 1 -> raise Not_comparable
+ | _ -> failwith "uh?"
+
+(* partial order *)
+let combine_comparison_list l =
+ fold_left compare_best 0 l
+
+let min_with_cmp less_than a b =
+ if less_than a b then a
+ else if less_than b a then b
+ else raise Not_comparable
+
+let max_with_cmp less_than a b =
+ if less_than a b then b
+ else if less_than b a then a
+ else raise Not_comparable
+
+let rec fold_left2_compare f e l1 l2 =
+ match l1, l2 with
+ | [], [] -> e
+ | e1::l1, e2::l2 -> fold_left2_compare f (f e e1 e2) l1 l2
+ | _ -> raise Not_comparable
+
+let rec exists_compare cmp = function
+ | [] -> raise Not_comparable
+ | e :: l -> try cmp e with Not_comparable -> exists_compare cmp l
+
+let forall_compare cmp = fold_left (fun n e -> compare_best n (cmp e)) 0
+let forall2_compare cmp = fold_left2_compare (fun n e1 e2 -> compare_best n (cmp e1 e2)) 0
+
+let exists2_compare left_dropping cmp l1 l2 =
+ let rec forall_compare_ n = function
+ | [], [] -> n
+ | _, [] -> compare_best n left_dropping
+ | [], _ -> compare_best n (-left_dropping)
+ | e1::l1, e2::l2 ->
+ match try Some (cmp e1 e2) with Not_comparable -> None with
+ | Some n' -> forall_compare_ (compare_best n n') (l1, l2)
+ | None ->
+ if n = left_dropping then
+ forall_compare_ left_dropping (l1, e2::l2)
+ else if n = -left_dropping then
+ forall_compare_ (-left_dropping) (e1::l1, l2)
+ else
+ (* need to try both *)
+ try forall_compare_ left_dropping (l1, e2::l2)
+ with Not_comparable -> forall_compare_ (-left_dropping) (e1::l1, l2)
+ in forall_compare_ 0 (l1, l2)
+
+
+let rec compare_sorted_sets is_same l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | [], _ -> -1
+ | _, [] -> 1
+ | e1::l1, e2::l2 -> if is_same e1 e2 then compare_sorted_sets is_same l1 l2 else raise Not_found
+
+let scan_list_while_modifying f l =
+ let rec scan_list_while_modifying_ prev = function
+ | [] -> prev
+ | e :: next ->
+ let prev', next' = some_or (f prev next e) (prev @ [e], next) in
+ scan_list_while_modifying_ prev' next'
+ in scan_list_while_modifying_ [] l
+
+let bools2compare = function
+ | true, true -> 0
+ | true, false -> -1
+ | false, true -> 1
+ | _ -> raise Not_comparable
+
+let lpush l e = l := e :: !l
+
+(*
+let is_greater2compare is_greater a b =
+ match is_greater a b, is_greater b a with
+
+ *)
+
+module OrderedString =
+ struct
+ type t = string
+ let compare = compare
+ end;;
+
+module StringSet = Set.Make(OrderedString);;
+
+let stringSet_to_list = StringSet.elements
+let stringSet_add set e = StringSet.add e set
+let stringSet_difference = StringSet.diff
+let list_to_StringSet l = fold_left stringSet_add StringSet.empty l
generated by cgit v1.2.1 (git 2.21.0) at 2024-11-04 20:24:31 +0000