sortedList.ml 10.5 KB
Newer Older
1
2
module type S =
sig
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
  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
24
    (* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
25
26
27
28
29
  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
30
31

  module Map: sig
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    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
64
  end
65
66
67
end


68
69
70
71
72
73
74
75
76
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98

  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

99

100
101
102
103
104
105
106
  let iter = List.iter

  let filter = List.filter
  let exists = List.exists
  let fold = List.fold_left


107
  external get: t -> elem list = "%identity"
108
109
110
111
112
113
114
115
  let singleton x = [ x ]

  let pick = function x::_ -> Some x | _ -> None 
  let length = List.length

  let empty = []
  let is_empty l = l = []

116
let rec disjoint l1 l2 =
117
  if l1 == l2 then l1 == [] else
118
119
  match (l1,l2) with
    | (t1::q1, t2::q2) -> 
120
	let c = X.compare t1 t2 in
121
122
123
124
125
126
	if c < 0 then disjoint q1 l2
	else if c > 0 then disjoint l1 q2
	else false
    | _ -> true
	
let rec cup l1 l2 =
127
  if l1 == l2 then l1 else
128
129
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
130
	let c = X.compare t1 t2 in
131
132
133
134
135
136
137
138
139
140
141
	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) ->
142
	let c = X.compare t1 t2 in
143
144
145
146
147
148
149
	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 =
150
  if l1 == l2 then [] else
151
152
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
153
	let c = X.compare t1 t2 in
154
155
156
157
158
	if c = 0 then diff q1 q2
	else if c < 0 then t1::(diff q1 l2)
	else diff l1 q2
    | _ -> l1

159
160
let remove x l = diff l [x]

161
let rec cap l1 l2 =
162
  if l1 == l2 then l1 else
163
164
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
165
	let c = X.compare t1 t2 in
166
167
168
169
170
171
172
	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 =
173
  (l1 == l2) ||
174
175
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
176
	let c = X.compare t1 t2 in
177
178
179
180
181
182
183
184
185
186
	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
	)
187
188
	else if c < 0 then false
	else subset l1 q2
189
    | [],_ -> true | _ -> false
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
	
	
	
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 -> 
213
        let c = X.compare x t in
214
215
        (c = 0) || ((c > 0) && (mem q x))

216
module Map = struct
217
218
  type 'a map = (X.t * 'a) list
  external get: 'a map -> (elem * 'a) list = "%identity"
219
220
221
222
  let empty = []
  let is_empty l = l = []
  let singleton x y = [ (x,y) ]

223
224
225
226
  let rec iter f = function
    | (_,y)::l -> f y; iter f l
    | [] -> ()

227
228
229
230
  let rec filter f = function
    | ((x,y) as c)::l -> if f x y then c::(filter f l) else filter f l
    | [] -> []

231
232
233
  let rec assoc_remove_aux v r = function
    | ((x,y) as a)::l ->
	let c = X.compare x v in
234
	if c = 0 then (r := Some y; l) 
235
236
237
238
239
	else if c < 0 then a :: (assoc_remove_aux v r l)
	else raise Not_found
    | [] -> raise Not_found

  let assoc_remove v l =
240
    let r = ref None in
241
    let l = assoc_remove_aux v r l in
242
    match !r with Some x -> (x,l) | _ -> assert false
243

244
245
246
247
248
249
250
251
252
253
(* 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
    | [] -> []

254
255
256
257
258
259
260
261
262
263
  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

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
  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

282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
  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)

317
318
319
320
321
322
323
324
325
326
327
328
329
  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)

330
331
332
333
334
335
336
337
338
339
340
341
342
343
  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)
    | [] -> []

344
345
346
347
  let rec mapi f = function
    | (x,y)::l -> (x, f x y)::(mapi f l)
    | [] -> []

348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
  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

370
371
372
373
374
375
376
  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

377
378
379
380
381
382
383
384
385
386
  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

387
388
389
  let rec hash f = function
    | [] -> 1
    | (x,y)::l -> X.hash x + 17 * (f y) + 257 * (hash f l)
390
391
392
393
394
395
396
397

  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

398
399
end

400

401
402
403
404
405
406
407
408
409
410
  module MakeMap(Y : Custom.T) = struct
    include Custom.Dummy
    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 
  end
411
end
412