viewcvs.cgi/types/sortedList.ml

module type S =
sig
  include Custom.T
  type elem

  external get: t -> elem list = "%identity"

  val singleton: elem -> t
  val iter: (elem -> unit) -> t -> unit
  val filter: (elem -> bool) -> t -> t
  val exists: (elem -> bool) -> t -> bool
  val fold: ('a -> elem -> 'a) -> 'a -> t -> 'a
  val pick: t -> elem option
  val length: t -> int

  val empty: t
  val is_empty: t -> bool
  val from_list : elem list -> t
  val add: elem -> t -> t
  val remove: elem -> t -> t
  val disjoint: t -> t -> bool
  val cup: t -> t -> t
  val split: t -> t -> t * t * t
    (* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
  val cap:  t -> t -> t
  val diff: t -> t -> t
  val subset: t -> t -> bool
  val map: (elem -> elem) -> t -> t
  val mem: t -> elem -> bool

  module Map: sig
    type 'a map
    external get: 'a map -> (elem * 'a) list = "%identity"
    val empty: 'a map
    val iter: ('a -> unit) -> 'a map -> unit
    val filter: (elem -> 'a -> bool) -> 'a map -> 'a map
    val is_empty: 'a map -> bool
    val singleton: elem -> 'a -> 'a map
    val assoc_remove: elem -> 'a map -> 'a * 'a map
    val remove:  elem -> 'a map -> 'a map
    val merge: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map
    val cap: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map
    val sub: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map

    val merge_elem: 'a -> 'a map -> 'a map -> 'a map
    val union_disj: 'a map -> 'a map -> 'a map
    val diff: 'a map -> t -> 'a map
    val from_list: ('a -> 'a -> 'a ) -> (elem * 'a) list -> 'a map
    val from_list_disj: (elem * 'a) list -> 'a map

    val map_from_slist: (elem -> 'a) -> t -> 'a map
    val collide: ('a -> 'b -> unit) -> 'a map -> 'b map -> unit
    val map: ('a -> 'b) -> 'a map -> 'b map
    val mapi: (elem -> 'a -> 'b) -> 'a map -> 'b map
    val constant: 'a -> t -> 'a map
    val num: int -> t -> int map
    val map_to_list: ('a -> 'b) -> 'a map -> 'b list
    val mapi_to_list: (elem -> 'a -> 'b) -> 'a map -> 'b list
    val assoc: elem -> 'a map -> 'a
    val assoc_present:  elem -> 'a map -> 'a
    val compare: ('a -> 'a -> int) -> 'a map -> 'a map -> int
    val hash: ('a -> int) -> 'a map -> int
    val equal: ('a -> 'a -> bool) -> 'a map -> 'a map -> bool
  end
end


module Make(X : Custom.T) = struct
  include Custom.List(X)
  let rec check = function
    | x::(y::_ as tl) -> X.check x; assert (X.compare x y < 0); check tl
    | [x] -> X.check x;
    | _ -> ()

  type elem = 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: t -> 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)

(* The order of elements might have changed since serialization *)
  let deserialize f = from_list (deserialize f)


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))

module Map = struct
  type 'a map = (X.t * 'a) list
  external get: 'a map -> (elem * 'a) 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 filter f = function
    | ((x,y) as c)::l -> if f x y then c::(filter f l) else filter 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 rec cap 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))::(cap f q1 q2)
          else if c < 0 then cap f q1 l2
          else cap f l1 q2
      | _ -> []

  let rec sub 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))::(sub f q1 q2)
          else if c < 0 then t1::(sub f q1 l2)
          else sub f l1 q2
      | (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


  let serialize f t l =
    Serialize.Put.list (Serialize.Put.pair X.serialize f) t l
  let deserialize f t =
    from_list_disj 
        (Serialize.Get.list (Serialize.Get.pair X.deserialize f) t)

  let rec check f = function
    | (x,a)::((y,b)::_ as tl) -> 
        X.check x; f a;
        assert (X.compare x y < 0); check f tl
    | [x,a] -> X.check x; f a
    | _ -> ()
    
end


  module MakeMap(Y : Custom.T) = struct
    type t = Y.t Map.map
        (* Note: need to eta expand these definitions, because
           of the compilation of the recursive module definitions
           in types.ml... *)
    let hash x = Map.hash Y.hash x
    let compare x y = Map.compare Y.compare x y
    let equal x y = Map.equal Y.equal x y 

    let check l = Map.check Y.check l
    let dump ppf _ = Format.fprintf ppf "<SortedList.MakeMap>"

    let serialize t l =
      Serialize.Put.list (Serialize.Put.pair X.serialize Y.serialize) t l

    let deserialize t =
      Map.from_list_disj 
        (Serialize.Get.list (Serialize.Get.pair X.deserialize Y.deserialize) t)
  end
end

1	module type S =
2	sig
3	include Custom.T
4	type elem
5
6	external get: t -> elem list = "%identity"
7
8	val singleton: elem -> t
9	val iter: (elem -> unit) -> t -> unit
10	val filter: (elem -> bool) -> t -> t
11	val exists: (elem -> bool) -> t -> bool
12	val fold: ('a -> elem -> 'a) -> 'a -> t -> 'a
13	val pick: t -> elem option
14	val length: t -> int
15
16	val empty: t
17	val is_empty: t -> bool
18	val from_list : elem list -> t
19	val add: elem -> t -> t
20	val remove: elem -> t -> t
21	val disjoint: t -> t -> bool
22	val cup: t -> t -> t
23	val split: t -> t -> t * t * t
24	(* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
25	val cap: t -> t -> t
26	val diff: t -> t -> t
27	val subset: t -> t -> bool
28	val map: (elem -> elem) -> t -> t
29	val mem: t -> elem -> bool
30
31	module Map: sig
32	type 'a map
33	external get: 'a map -> (elem * 'a) list = "%identity"
34	val empty: 'a map
35	val iter: ('a -> unit) -> 'a map -> unit
36	val filter: (elem -> 'a -> bool) -> 'a map -> 'a map
37	val is_empty: 'a map -> bool
38	val singleton: elem -> 'a -> 'a map
39	val assoc_remove: elem -> 'a map -> 'a * 'a map
40	val remove: elem -> 'a map -> 'a map
41	val merge: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map
42	val cap: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map
43	val sub: ('a -> 'a -> 'a ) -> 'a map -> 'a map -> 'a map
44
45	val merge_elem: 'a -> 'a map -> 'a map -> 'a map
46	val union_disj: 'a map -> 'a map -> 'a map
47	val diff: 'a map -> t -> 'a map
48	val from_list: ('a -> 'a -> 'a ) -> (elem * 'a) list -> 'a map
49	val from_list_disj: (elem * 'a) list -> 'a map
50
51	val map_from_slist: (elem -> 'a) -> t -> 'a map
52	val collide: ('a -> 'b -> unit) -> 'a map -> 'b map -> unit
53	val map: ('a -> 'b) -> 'a map -> 'b map
54	val mapi: (elem -> 'a -> 'b) -> 'a map -> 'b map
55	val constant: 'a -> t -> 'a map
56	val num: int -> t -> int map
57	val map_to_list: ('a -> 'b) -> 'a map -> 'b list
58	val mapi_to_list: (elem -> 'a -> 'b) -> 'a map -> 'b list
59	val assoc: elem -> 'a map -> 'a
60	val assoc_present: elem -> 'a map -> 'a
61	val compare: ('a -> 'a -> int) -> 'a map -> 'a map -> int
62	val hash: ('a -> int) -> 'a map -> int
63	val equal: ('a -> 'a -> bool) -> 'a map -> 'a map -> bool
64	end
65	end
66
67
68	module Make(X : Custom.T) = struct
69	include Custom.List(X)
70	let rec check = function
71	\| x::(y::_ as tl) -> X.check x; assert (X.compare x y < 0); check tl
72	\| [x] -> X.check x;
73	\| _ -> ()
74
75	type elem = X.t
76
77	let rec equal l1 l2 =
78	(l1 == l2) \|\|
79	match (l1,l2) with
80	\| x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
81	\| _ -> false
82
83	let rec hash accu = function
84	\| [] -> 1 + accu
85	\| x::l -> hash (17 * accu + X.hash x) l
86
87	let hash l = hash 1 l
88
89	let rec compare l1 l2 =
90	if l1 == l2 then 0
91	else match (l1,l2) with
92	\| x1::l1, x2::l2 ->
93	let c = X.compare x1 x2 in if c <> 0 then c
94	else compare l1 l2
95	\| [],_ -> -1
96	\| _ -> 1
97
98
99	let iter = List.iter
100
101	let filter = List.filter
102	let exists = List.exists
103	let fold = List.fold_left
104
105
106	external get: t -> elem list = "%identity"
107	let singleton x = [ x ]
108
109	let pick = function x::_ -> Some x \| _ -> None
110	let length = List.length
111
112	let empty = []
113	let is_empty l = l = []
114
115	let rec disjoint l1 l2 =
116	if l1 == l2 then l1 == [] else
117	match (l1,l2) with
118	\| (t1::q1, t2::q2) ->
119	let c = X.compare t1 t2 in
120	if c < 0 then disjoint q1 l2
121	else if c > 0 then disjoint l1 q2
122	else false
123	\| _ -> true
124
125	let rec cup l1 l2 =
126	if l1 == l2 then l1 else
127	match (l1,l2) with
128	\| (t1::q1, t2::q2) ->
129	let c = X.compare t1 t2 in
130	if c = 0 then t1::(cup q1 q2)
131	else if c < 0 then t1::(cup q1 l2)
132	else t2::(cup l1 q2)
133	\| ([],l2) -> l2
134	\| (l1,[]) -> l1
135
136	let add x l = cup [x] l
137
138	let rec split l1 l2 =
139	match (l1,l2) with
140	\| (t1::q1, t2::q2) ->
141	let c = X.compare t1 t2 in
142	if c = 0 then let (l1,i,l2) = split q1 q2 in (l1,t1::i,l2)
143	else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2)
144	else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2)
145	\| _ -> (l1,[],l2)
146
147
148	let rec diff l1 l2 =
149	if l1 == l2 then [] else
150	match (l1,l2) with
151	\| (t1::q1, t2::q2) ->
152	let c = X.compare t1 t2 in
153	if c = 0 then diff q1 q2
154	else if c < 0 then t1::(diff q1 l2)
155	else diff l1 q2
156	\| _ -> l1
157
158	let remove x l = diff l [x]
159
160	let rec cap l1 l2 =
161	if l1 == l2 then l1 else
162	match (l1,l2) with
163	\| (t1::q1, t2::q2) ->
164	let c = X.compare t1 t2 in
165	if c = 0 then t1::(cap q1 q2)
166	else if c < 0 then cap q1 l2
167	else cap l1 q2
168	\| _ -> []
169
170
171	let rec subset l1 l2 =
172	(l1 == l2) \|\|
173	match (l1,l2) with
174	\| (t1::q1, t2::q2) ->
175	let c = X.compare t1 t2 in
176	if c = 0 then (
177	(* inlined: subset q1 q2 *)
178	(q1 == q2) \|\| match (q1,q2) with
179	\| (t1::qq1, t2::qq2) ->
180	let c = X.compare t1 t2 in
181	if c = 0 then subset qq1 qq2
182	else if c < 0 then false
183	else subset q1 qq2
184	\| [],_ -> true \| _ -> false
185	)
186	else if c < 0 then false
187	else subset l1 q2
188	\| [],_ -> true \| _ -> false
189
190
191
192	let from_list l =
193	let rec initlist = function
194	\| [] -> []
195	\| e::rest -> [e] :: initlist rest in
196	let rec merge2 = function
197	\| l1::l2::rest -> cup l1 l2 :: merge2 rest
198	\| x -> x in
199	let rec mergeall = function
200	\| [] -> []
201	\| [l] -> l
202	\| llist -> mergeall (merge2 llist) in
203	mergeall (initlist l)
204
205	let map f l =
206	from_list (List.map f l)
207
208	(* The order of elements might have changed since serialization *)
209	let deserialize f = from_list (deserialize f)
210
211
212	let rec mem l x =
213	match l with
214	\| [] -> false
215	\| t::q ->
216	let c = X.compare x t in
217	(c = 0) \|\| ((c > 0) && (mem q x))
218
219	module Map = struct
220	type 'a map = (X.t * 'a) list
221	external get: 'a map -> (elem * 'a) list = "%identity"
222	let empty = []
223	let is_empty l = l = []
224	let singleton x y = [ (x,y) ]
225
226	let rec iter f = function
227	\| (_,y)::l -> f y; iter f l
228	\| [] -> ()
229
230	let rec filter f = function
231	\| ((x,y) as c)::l -> if f x y then c::(filter f l) else filter f l
232	\| [] -> []
233
234	let rec assoc_remove_aux v r = function
235	\| ((x,y) as a)::l ->
236	let c = X.compare x v in
237	if c = 0 then (r := Some y; l)
238	else if c < 0 then a :: (assoc_remove_aux v r l)
239	else raise Not_found
240	\| [] -> raise Not_found
241
242	let assoc_remove v l =
243	let r = ref None in
244	let l = assoc_remove_aux v r l in
245	match !r with Some x -> (x,l) \| _ -> assert false
246
247	(* TODO: is is faster to raise exception Not_found and return
248	original list ? *)
249	let rec remove v = function
250	\| (((x,y) as a)::rem) as l->
251	let c = X.compare x v in
252	if c = 0 then rem
253	else if c < 0 then a :: (remove v rem)
254	else l
255	\| [] -> []
256
257	let rec merge f l1 l2 =
258	match (l1,l2) with
259	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
260	let c = X.compare x1 x2 in
261	if c = 0 then (x1,(f y1 y2))::(merge f q1 q2)
262	else if c < 0 then t1::(merge f q1 l2)
263	else t2::(merge f l1 q2)
264	\| ([],l2) -> l2
265	\| (l1,[]) -> l1
266
267	let rec cap f l1 l2 =
268	match (l1,l2) with
269	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
270	let c = X.compare x1 x2 in
271	if c = 0 then (x1,(f y1 y2))::(cap f q1 q2)
272	else if c < 0 then cap f q1 l2
273	else cap f l1 q2
274	\| _ -> []
275
276	let rec sub f l1 l2 =
277	match (l1,l2) with
278	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
279	let c = X.compare x1 x2 in
280	if c = 0 then (x1,(f y1 y2))::(sub f q1 q2)
281	else if c < 0 then t1::(sub f q1 l2)
282	else sub f l1 q2
283	\| (l1,_) -> l1
284
285	let merge_elem x l1 l2 = merge (fun _ _ -> x) l1 l2
286	(* TODO: optimize this ? *)
287
288	let rec union_disj l1 l2 =
289	match (l1,l2) with
290	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
291	let c = X.compare x1 x2 in
292	if c = 0 then failwith "SortedList.Map.union_disj"
293	else if c < 0 then t1::(union_disj q1 l2)
294	else t2::(union_disj l1 q2)
295	\| ([],l2) -> l2
296	\| (l1,[]) -> l1
297
298	let rec diff l1 l2 =
299	match (l1,l2) with
300	\| (((x1,y1) as t1)::q1, x2::q2) ->
301	let c = X.compare x1 x2 in
302	if c = 0 then diff q1 q2
303	else if c < 0 then t1::(diff q1 l2)
304	else diff l1 q2
305	\| _ -> l1
306
307	let from_list f l =
308	let rec initlist = function
309	\| [] -> []
310	\| e::rest -> [e] :: initlist rest in
311	let rec merge2 = function
312	\| l1::l2::rest -> merge f l1 l2 :: merge2 rest
313	\| x -> x in
314	let rec mergeall = function
315	\| [] -> []
316	\| [l] -> l
317	\| llist -> mergeall (merge2 llist) in
318	mergeall (initlist l)
319
320	let from_list_disj l =
321	let rec initlist = function
322	\| [] -> []
323	\| e::rest -> [e] :: initlist rest in
324	let rec merge2 = function
325	\| l1::l2::rest -> union_disj l1 l2 :: merge2 rest
326	\| x -> x in
327	let rec mergeall = function
328	\| [] -> []
329	\| [l] -> l
330	\| llist -> mergeall (merge2 llist) in
331	mergeall (initlist l)
332
333	let rec map_from_slist f = function
334	\| x::l -> (x,f x)::(map_from_slist f l)
335	\| [] -> []
336
337	let rec collide f l1 l2 =
338	match (l1,l2) with
339	\| (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2
340	\| [],[] -> ()
341	\| _ -> assert false
342
343	let rec map f = function
344	\| (x,y)::l -> (x, f y)::(map f l)
345	\| [] -> []
346
347	let rec mapi f = function
348	\| (x,y)::l -> (x, f x y)::(mapi f l)
349	\| [] -> []
350
351	let rec mapi_to_list f = function
352	\| (x,y)::l -> (f x y) ::(mapi_to_list f l)
353	\| [] -> []
354
355	let rec constant y = function
356	\| x::l -> (x,y)::(constant y l)
357	\| [] -> []
358
359	let rec num i = function [] -> [] \| h::t -> (h,i)::(num (i+1) t)
360
361	let rec map_to_list f = function
362	\| (x,y)::l -> (f y)::(map_to_list f l)
363	\| [] -> []
364
365	let rec assoc v = function
366	\| (x,y)::l ->
367	let c = X.compare x v in
368	if c = 0 then y
369	else if c < 0 then assoc v l
370	else raise Not_found
371	\| [] -> raise Not_found
372
373	let rec assoc_present v = function
374	\| [(_,y)] -> y
375	\| (x,y)::l ->
376	let c = X.compare x v in
377	if c = 0 then y else assoc_present v l
378	\| [] -> assert false
379
380	let rec compare f l1 l2 =
381	if l1 == l2 then 0
382	else match (l1,l2) with
383	\| (x1,y1)::l1, (x2,y2)::l2 ->
384	let c = X.compare x1 x2 in if c <> 0 then c
385	else let c = f y1 y2 in if c <> 0 then c
386	else compare f l1 l2
387	\| [],_ -> -1
388	\| _,[] -> 1
389
390	let rec hash f = function
391	\| [] -> 1
392	\| (x,y)::l -> X.hash x + 17 * (f y) + 257 * (hash f l)
393
394	let rec equal f l1 l2 =
395	(l1 == l2) \|\|
396	match (l1,l2) with
397	\| (x1,y1)::l1, (x2,y2)::l2 ->
398	(X.equal x1 x2) && (f y1 y2) && (equal f l1 l2)
399	\| _ -> false
400
401
402	let serialize f t l =
403	Serialize.Put.list (Serialize.Put.pair X.serialize f) t l
404	let deserialize f t =
405	from_list_disj
406	(Serialize.Get.list (Serialize.Get.pair X.deserialize f) t)
407
408	let rec check f = function
409	\| (x,a)::((y,b)::_ as tl) ->
410	X.check x; f a;
411	assert (X.compare x y < 0); check f tl
412	\| [x,a] -> X.check x; f a
413	\| _ -> ()
414
415	end
416
417
418	module MakeMap(Y : Custom.T) = struct
419	type t = Y.t Map.map
420	(* Note: need to eta expand these definitions, because
421	of the compilation of the recursive module definitions
422	in types.ml... *)
423	let hash x = Map.hash Y.hash x
424	let compare x y = Map.compare Y.compare x y
425	let equal x y = Map.equal Y.equal x y
426
427	let check l = Map.check Y.check l
428	let dump ppf _ = Format.fprintf ppf "<SortedList.MakeMap>"
429
430	let serialize t l =
431	Serialize.Put.list (Serialize.Put.pair X.serialize Y.serialize) t l
432
433	let deserialize t =
434	Map.from_list_disj
435	(Serialize.Get.list (Serialize.Get.pair X.deserialize Y.deserialize) t)
436	end
437	end
438