viewcvs.cgi/types/sortedList.ml

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 is_empty: ('a,'b) map -> bool
    val singleton: 'a elem -> 'b -> ('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 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 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
  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 =
  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 =
  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 =
  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 =
  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 =
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
        let c = X.compare t1 t2 in
        if c = 0 then subset q1 q2
        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 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 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_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

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

include Make(
  struct 
    type 'a t = 'a 
    let hash = Hashtbl.hash 
    let equal x y = x = y 
    let compare = compare 
  end)
1	module type ARG = sig
2	type 'a t
3	val equal: 'a t -> 'a t -> bool
4	val hash: 'a t -> int
5	val compare: 'a t -> 'a t -> int
6	end
7
8	module type ARG0 =
9	sig
10	type t
11	val equal: t -> t -> bool
12	val hash: t -> int
13	val compare: t -> t -> int
14	end
15
16	module Lift(X : ARG0) =
17	struct
18	type 'a t = X.t
19	let equal = X.equal
20	let hash = X.hash
21	let compare = X.compare
22	end
23
24	module type S =
25	sig
26	type 'a elem
27	type 'a t
28	val equal: 'a t -> 'a t -> bool
29	val hash: 'a t -> int
30	val compare: 'a t -> 'a t -> int
31
32	external get: 'a t -> 'a elem list = "%identity"
33
34	val singleton: 'a elem -> 'a t
35	val iter: ('a elem -> unit) -> 'a t -> unit
36	val filter: ('a elem -> bool) -> 'a t -> 'a t
37	val exists: ('a elem -> bool) -> 'a t -> bool
38	val fold: ('b -> 'a elem -> 'b) -> 'b -> 'a t -> 'b
39	val pick: 'a t -> 'a elem option
40	val length: 'a t -> int
41
42	val empty: 'a t
43	val is_empty: 'a t -> bool
44	val from_list : 'a elem list -> 'a t
45	val add: 'a elem -> 'a t -> 'a t
46	val remove: 'a elem -> 'a t -> 'a t
47	val disjoint: 'a t -> 'a t -> bool
48	val cup: 'a t -> 'a t -> 'a t
49	val split: 'a t -> 'a t -> 'a t * 'a t * 'a t
50	(* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
51	val cap: 'a t -> 'a t -> 'a t
52	val diff: 'a t -> 'a t -> 'a t
53	val subset: 'a t -> 'a t -> bool
54	val map: ('a elem-> 'b elem) -> 'a t -> 'b t
55	val mem: 'a t -> 'a elem -> bool
56
57	val check: 'a elem list -> unit
58
59	module Map: sig
60	type ('a,'b) map
61	external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
62	val empty: ('a,'b) map
63	val is_empty: ('a,'b) map -> bool
64	val singleton: 'a elem -> 'b -> ('a,'b) map
65	val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
66	val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
67	val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
68	val diff: ('a,'b) map -> 'a t -> ('a,'b) map
69	val from_list: ('b -> 'b -> 'b ) -> ('a elem * 'b) list -> ('a,'b) map
70	val map_from_slist: ('a elem -> 'b) -> 'a t -> ('a,'b) map
71	val collide: ('b -> 'c -> unit) -> ('a,'b) map -> ('a,'c) map -> unit
72	val map: ('b -> 'c) -> ('a,'b) map -> ('a,'c) map
73	val constant: 'b -> 'a t -> ('a,'b) map
74	val num: int -> 'a t -> ('a,int) map
75	val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
76	val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list
77	val assoc: 'a elem -> ('a,'b) map -> 'b
78	end
79	end
80
81	module Make_transp(X : ARG) = struct
82
83	type 'a t = 'a X.t list
84	type 'a elem = 'a X.t
85
86	let rec equal l1 l2 =
87	(l1 == l2) \|\|
88	match (l1,l2) with
89	\| x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
90	\| _ -> false
91
92	let rec hash accu = function
93	\| [] -> 1 + accu
94	\| x::l -> hash (17 * accu + X.hash x) l
95
96	let hash l = hash 1 l
97
98	let rec compare l1 l2 =
99	if l1 == l2 then 0
100	else match (l1,l2) with
101	\| x1::l1, x2::l2 ->
102	let c = X.compare x1 x2 in if c <> 0 then c
103	else compare l1 l2
104	\| [],_ -> -1
105	\| _ -> 1
106
107
108	let iter = List.iter
109
110	let filter = List.filter
111	let exists = List.exists
112	let fold = List.fold_left
113
114
115	external get: 'a t -> 'a elem list = "%identity"
116	let singleton x = [ x ]
117
118	let pick = function x::_ -> Some x \| _ -> None
119	let length = List.length
120
121	let empty = []
122	let is_empty l = l = []
123
124	let rec disjoint l1 l2 =
125	match (l1,l2) with
126	\| (t1::q1, t2::q2) ->
127	let c = X.compare t1 t2 in
128	if c < 0 then disjoint q1 l2
129	else if c > 0 then disjoint l1 q2
130	else false
131	\| _ -> true
132
133	let rec cup l1 l2 =
134	match (l1,l2) with
135	\| (t1::q1, t2::q2) ->
136	let c = X.compare t1 t2 in
137	if c = 0 then t1::(cup q1 q2)
138	else if c < 0 then t1::(cup q1 l2)
139	else t2::(cup l1 q2)
140	\| ([],l2) -> l2
141	\| (l1,[]) -> l1
142
143	let add x l = cup [x] l
144
145	let rec split l1 l2 =
146	match (l1,l2) with
147	\| (t1::q1, t2::q2) ->
148	let c = X.compare t1 t2 in
149	if c = 0 then let (l1,i,l2) = split q1 q2 in (l1,t1::i,l2)
150	else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2)
151	else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2)
152	\| _ -> (l1,[],l2)
153
154
155	let rec diff l1 l2 =
156	match (l1,l2) with
157	\| (t1::q1, t2::q2) ->
158	let c = X.compare t1 t2 in
159	if c = 0 then diff q1 q2
160	else if c < 0 then t1::(diff q1 l2)
161	else diff l1 q2
162	\| _ -> l1
163
164	let remove x l = diff l [x]
165
166	let rec cap l1 l2 =
167	match (l1,l2) with
168	\| (t1::q1, t2::q2) ->
169	let c = X.compare t1 t2 in
170	if c = 0 then t1::(cap q1 q2)
171	else if c < 0 then cap q1 l2
172	else cap l1 q2
173	\| _ -> []
174
175
176	let rec subset l1 l2 =
177	match (l1,l2) with
178	\| (t1::q1, t2::q2) ->
179	let c = X.compare t1 t2 in
180	if c = 0 then subset q1 q2
181	else if c < 0 then false
182	else subset l1 q2
183	\| [],_ -> true
184	\| _ -> false
185
186
187
188	let from_list l =
189	let rec initlist = function
190	\| [] -> []
191	\| e::rest -> [e] :: initlist rest in
192	let rec merge2 = function
193	\| l1::l2::rest -> cup l1 l2 :: merge2 rest
194	\| x -> x in
195	let rec mergeall = function
196	\| [] -> []
197	\| [l] -> l
198	\| llist -> mergeall (merge2 llist) in
199	mergeall (initlist l)
200
201	let map f l =
202	from_list (List.map f l)
203
204	let rec mem l x =
205	match l with
206	\| [] -> false
207	\| t::q ->
208	let c = X.compare x t in
209	(c = 0) \|\| ((c > 0) && (mem q x))
210
211	let rec check = function
212	\| a::(b::_ as t) -> assert (X.compare a b < 0); check t
213	\| _ -> ()
214
215	module Map = struct
216	type ('a,'b) map = ('a X.t * 'b) list
217	external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
218	let empty = []
219	let is_empty l = l = []
220	let singleton x y = [ (x,y) ]
221
222	let rec merge f l1 l2 =
223	match (l1,l2) with
224	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
225	let c = X.compare x1 x2 in
226	if c = 0 then (x1,(f y1 y2))::(merge f q1 q2)
227	else if c < 0 then t1::(merge f q1 l2)
228	else t2::(merge f l1 q2)
229	\| ([],l2) -> l2
230	\| (l1,[]) -> l1
231
232	let merge_elem x l1 l2 = merge (fun _ _ -> x) l1 l2
233	(* TODO: optimize this ? *)
234
235	let rec union_disj l1 l2 =
236	match (l1,l2) with
237	\| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
238	let c = X.compare x1 x2 in
239	if c = 0 then failwith "SortedList.Map.union_disj"
240	else if c < 0 then t1::(union_disj q1 l2)
241	else t2::(union_disj l1 q2)
242	\| ([],l2) -> l2
243	\| (l1,[]) -> l1
244
245	let rec diff l1 l2 =
246	match (l1,l2) with
247	\| (((x1,y1) as t1)::q1, x2::q2) ->
248	let c = X.compare x1 x2 in
249	if c = 0 then diff q1 q2
250	else if c < 0 then t1::(diff q1 l2)
251	else diff l1 q2
252	\| _ -> l1
253
254	let from_list f l =
255	let rec initlist = function
256	\| [] -> []
257	\| e::rest -> [e] :: initlist rest in
258	let rec merge2 = function
259	\| l1::l2::rest -> merge f l1 l2 :: merge2 rest
260	\| x -> x in
261	let rec mergeall = function
262	\| [] -> []
263	\| [l] -> l
264	\| llist -> mergeall (merge2 llist) in
265	mergeall (initlist l)
266
267	let rec map_from_slist f = function
268	\| x::l -> (x,f x)::(map_from_slist f l)
269	\| [] -> []
270
271	let rec collide f l1 l2 =
272	match (l1,l2) with
273	\| (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2
274	\| [],[] -> ()
275	\| _ -> assert false
276
277	let rec map f = function
278	\| (x,y)::l -> (x, f y)::(map f l)
279	\| [] -> []
280
281	let rec mapi_to_list f = function
282	\| (x,y)::l -> (f x y) ::(mapi_to_list f l)
283	\| [] -> []
284
285	let rec constant y = function
286	\| x::l -> (x,y)::(constant y l)
287	\| [] -> []
288
289	let rec num i = function [] -> [] \| h::t -> (h,i)::(num (i+1) t)
290
291	let rec map_to_list f = function
292	\| (x,y)::l -> (f y)::(map_to_list f l)
293	\| [] -> []
294
295	let rec assoc v = function
296	\| (x,y)::l ->
297	let c = X.compare x v in
298	if c = 0 then y
299	else if c < 0 then assoc v l
300	else raise Not_found
301	\| [] -> raise Not_found
302
303	end
304
305	end
306
307	module Make = Make_transp
308
309	module String =
310	struct
311	type t = string
312	let hash = Hashtbl.hash
313	let equal (x:t) (y:t) = x = y
314	let compare (x:t) (y:t) = compare x y
315	end
316
317	include Make(
318	struct
319	type 'a t = 'a
320	let hash = Hashtbl.hash
321	let equal x y = x = y
322	let compare = compare
323	end)