module type ARG = sig type 'a t val equal: 'a t -> 'a t -> bool val hash: 'a t -> int val compare: 'a t -> 'a t -> int end module type ARG0 = sig type t val equal: t -> t -> bool val hash: t -> int val compare: t -> t -> int end module Lift(X : ARG0) = struct type 'a t = X.t let equal = X.equal let hash = X.hash let compare = X.compare end module type S = sig type 'a elem type 'a t val equal: 'a t -> 'a t -> bool val hash: 'a t -> int val compare: 'a t -> 'a t -> int external get: 'a t -> 'a elem list = "%identity" val singleton: 'a elem -> 'a t val iter: ('a elem -> unit) -> 'a t -> unit val filter: ('a elem -> bool) -> 'a t -> 'a t val exists: ('a elem -> bool) -> 'a t -> bool val fold: ('b -> 'a elem -> 'b) -> 'b -> 'a t -> 'b val pick: 'a t -> 'a elem option val length: 'a t -> int val empty: 'a t val is_empty: 'a t -> bool val from_list : 'a elem list -> 'a t val add: 'a elem -> 'a t -> 'a t val remove: 'a elem -> 'a t -> 'a t val disjoint: 'a t -> 'a t -> bool val cup: 'a t -> 'a t -> 'a t val split: 'a t -> 'a t -> 'a t * 'a t * 'a t (* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *) val cap: 'a t -> 'a t -> 'a t val diff: 'a t -> 'a t -> 'a t val subset: 'a t -> 'a t -> bool val map: ('a elem-> 'b elem) -> 'a t -> 'b t val mem: 'a t -> 'a elem -> bool val check: 'a elem list -> unit module Map: sig type ('a,'b) map external get: ('a,'b) map -> ('a elem * 'b) list = "%identity" val empty: ('a,'b) map val iter: ('b -> unit) -> ('a,'b) map -> unit val is_empty: ('a,'b) map -> bool val singleton: 'a elem -> 'b -> ('a,'b) map val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map val remove: 'a elem -> ('a,'b) map -> ('a,'b) map val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map val diff: ('a,'b) map -> 'a t -> ('a,'b) map val from_list: ('b -> 'b -> 'b ) -> ('a elem * 'b) list -> ('a,'b) map val from_list_disj: ('a elem * 'b) list -> ('a,'b) map val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map val constant: 'b -> 'a t -> ('a,'b) map val num: int -> 'a t -> ('a,int) map val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list val assoc: 'a elem -> ('a,'b) map -> 'b val assoc_present: 'a elem -> ('a,'b) map -> 'b val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int val hash: ('b -> int) -> ('a,'b) map -> int val equal: ('b -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map -> bool end end module Make_transp(X : ARG) = struct type 'a t = 'a X.t list type 'a elem = 'a X.t let rec equal l1 l2 = (l1 == l2) || match (l1,l2) with | x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2) | _ -> false let rec hash accu = function | [] -> 1 + accu | x::l -> hash (17 * accu + X.hash x) l let hash l = hash 1 l let rec compare l1 l2 = if l1 == l2 then 0 else match (l1,l2) with | x1::l1, x2::l2 -> let c = X.compare x1 x2 in if c <> 0 then c else compare l1 l2 | [],_ -> -1 | _ -> 1 let iter = List.iter let filter = List.filter let exists = List.exists let fold = List.fold_left external get: 'a t -> 'a elem list = "%identity" let singleton x = [ x ] let pick = function x::_ -> Some x | _ -> None let length = List.length let empty = [] let is_empty l = l = [] let rec disjoint l1 l2 = if l1 == l2 then l1 == [] else match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c < 0 then disjoint q1 l2 else if c > 0 then disjoint l1 q2 else false | _ -> true let rec cup l1 l2 = if l1 == l2 then l1 else match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c = 0 then t1::(cup q1 q2) else if c < 0 then t1::(cup q1 l2) else t2::(cup l1 q2) | ([],l2) -> l2 | (l1,[]) -> l1 let add x l = cup [x] l let rec split l1 l2 = match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c = 0 then let (l1,i,l2) = split q1 q2 in (l1,t1::i,l2) else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2) else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2) | _ -> (l1,[],l2) let rec diff l1 l2 = if l1 == l2 then [] else match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c = 0 then diff q1 q2 else if c < 0 then t1::(diff q1 l2) else diff l1 q2 | _ -> l1 let remove x l = diff l [x] let rec cap l1 l2 = if l1 == l2 then l1 else match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c = 0 then t1::(cap q1 q2) else if c < 0 then cap q1 l2 else cap l1 q2 | _ -> [] let rec subset l1 l2 = (l1 == l2) || match (l1,l2) with | (t1::q1, t2::q2) -> let c = X.compare t1 t2 in if c = 0 then ( (* inlined: subset q1 q2 *) (q1 == q2) || match (q1,q2) with | (t1::qq1, t2::qq2) -> let c = X.compare t1 t2 in if c = 0 then subset qq1 qq2 else if c < 0 then false else subset q1 qq2 | [],_ -> true | _ -> false ) else if c < 0 then false else subset l1 q2 | [],_ -> true | _ -> false let from_list l = let rec initlist = function | [] -> [] | e::rest -> [e] :: initlist rest in let rec merge2 = function | l1::l2::rest -> cup l1 l2 :: merge2 rest | x -> x in let rec mergeall = function | [] -> [] | [l] -> l | llist -> mergeall (merge2 llist) in mergeall (initlist l) let map f l = from_list (List.map f l) let rec mem l x = match l with | [] -> false | t::q -> let c = X.compare x t in (c = 0) || ((c > 0) && (mem q x)) let rec check = function | a::(b::_ as t) -> assert (X.compare a b < 0); check t | _ -> () module Map = struct type ('a,'b) map = ('a X.t * 'b) list external get: ('a,'b) map -> ('a elem * 'b) list = "%identity" let empty = [] let is_empty l = l = [] let singleton x y = [ (x,y) ] let rec iter f = function | (_,y)::l -> f y; iter f l | [] -> () let rec assoc_remove_aux v r = function | ((x,y) as a)::l -> let c = X.compare x v in if c = 0 then (r := Some y; l) else if c < 0 then a :: (assoc_remove_aux v r l) else raise Not_found | [] -> raise Not_found let assoc_remove v l = let r = ref None in let l = assoc_remove_aux v r l in match !r with Some x -> (x,l) | _ -> assert false (* TODO: is is faster to raise exception Not_found and return original list ? *) let rec remove v = function | (((x,y) as a)::rem) as l-> let c = X.compare x v in if c = 0 then rem else if c < 0 then a :: (remove v rem) else l | [] -> [] let rec merge f l1 l2 = match (l1,l2) with | ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 -> let c = X.compare x1 x2 in if c = 0 then (x1,(f y1 y2))::(merge f q1 q2) else if c < 0 then t1::(merge f q1 l2) else t2::(merge f l1 q2) | ([],l2) -> l2 | (l1,[]) -> l1 let merge_elem x l1 l2 = merge (fun _ _ -> x) l1 l2 (* TODO: optimize this ? *) let rec union_disj l1 l2 = match (l1,l2) with | ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 -> let c = X.compare x1 x2 in if c = 0 then failwith "SortedList.Map.union_disj" else if c < 0 then t1::(union_disj q1 l2) else t2::(union_disj l1 q2) | ([],l2) -> l2 | (l1,[]) -> l1 let rec diff l1 l2 = match (l1,l2) with | (((x1,y1) as t1)::q1, x2::q2) -> let c = X.compare x1 x2 in if c = 0 then diff q1 q2 else if c < 0 then t1::(diff q1 l2) else diff l1 q2 | _ -> l1 let from_list f l = let rec initlist = function | [] -> [] | e::rest -> [e] :: initlist rest in let rec merge2 = function | l1::l2::rest -> merge f l1 l2 :: merge2 rest | x -> x in let rec mergeall = function | [] -> [] | [l] -> l | llist -> mergeall (merge2 llist) in mergeall (initlist l) let from_list_disj l = let rec initlist = function | [] -> [] | e::rest -> [e] :: initlist rest in let rec merge2 = function | l1::l2::rest -> union_disj l1 l2 :: merge2 rest | x -> x in let rec mergeall = function | [] -> [] | [l] -> l | llist -> mergeall (merge2 llist) in mergeall (initlist l) let rec map_from_slist f = function | x::l -> (x,f x)::(map_from_slist f l) | [] -> [] let rec collide f l1 l2 = match (l1,l2) with | (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2 | [],[] -> () | _ -> assert false let rec map f = function | (x,y)::l -> (x, f y)::(map f l) | [] -> [] let rec mapi f = function | (x,y)::l -> (x, f x y)::(mapi f l) | [] -> [] let rec mapi_to_list f = function | (x,y)::l -> (f x y) ::(mapi_to_list f l) | [] -> [] let rec constant y = function | x::l -> (x,y)::(constant y l) | [] -> [] let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t) let rec map_to_list f = function | (x,y)::l -> (f y)::(map_to_list f l) | [] -> [] let rec assoc v = function | (x,y)::l -> let c = X.compare x v in if c = 0 then y else if c < 0 then assoc v l else raise Not_found | [] -> raise Not_found let rec assoc_present v = function | [(_,y)] -> y | (x,y)::l -> let c = X.compare x v in if c = 0 then y else assoc_present v l | [] -> assert false let rec compare f l1 l2 = if l1 == l2 then 0 else match (l1,l2) with | (x1,y1)::l1, (x2,y2)::l2 -> let c = X.compare x1 x2 in if c <> 0 then c else let c = f y1 y2 in if c <> 0 then c else compare f l1 l2 | [],_ -> -1 | _,[] -> 1 let rec hash f = function | [] -> 1 | (x,y)::l -> X.hash x + 17 * (f y) + 257 * (hash f l) let rec equal f l1 l2 = (l1 == l2) || match (l1,l2) with | (x1,y1)::l1, (x2,y2)::l2 -> (X.equal x1 x2) && (f y1 y2) && (equal f l1 l2) | _ -> false end end module Make = Make_transp module String = struct type t = string let hash = Hashtbl.hash let equal (x:t) (y:t) = x = y let compare (x:t) (y:t) = compare x y end