sortedList.ml 10.4 KB
Newer Older
1
2
3
4
5
6
7
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

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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

24
25
26
27
28
29
30
31
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

32
33
34
35
36
37
38
39
40
41
42
43
  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
44
45
  val from_list : 'a elem list -> 'a t
  val add: 'a elem -> 'a t -> 'a t
46
  val remove:  'a elem -> 'a t -> 'a t
47
48
49
50
51
52
53
54
55
56
57
  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
58
59
60
61
62

  module Map: sig
    type ('a,'b) map
    external get: ('a,'b) map -> ('a elem * 'b) list = "%identity"
    val empty: ('a,'b) map
63
    val iter: ('b -> unit) -> ('a,'b) map -> unit
64
65
    val is_empty: ('a,'b) map -> bool
    val singleton: 'a elem -> 'b -> ('a,'b) map
66
    val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
67
    val remove:  'a elem -> ('a,'b) map -> ('a,'b) map
68
69
70
71
72
    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
73
    val from_list_disj: ('a elem * 'b) list -> ('a,'b) map
74
75
76
    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
77
    val mapi: ('a elem -> 'b -> 'c) -> ('a,'b) map -> ('a,'c) map
78
79
80
81
82
    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
83
    val assoc_present:  'a elem -> ('a,'b) map -> 'b
84
85

    val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
86
    val hash: ('b -> int) -> ('a,'b) map -> int
87
    val equal: ('b -> 'b -> bool) -> ('a,'b) map -> ('a,'b) map -> bool
88
  end
89
90
end

91
module Make_transp(X : ARG) = struct
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

  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

117

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
  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 = []

134
let rec disjoint l1 l2 =
135
  if l1 == l2 then l1 == [] else
136
137
  match (l1,l2) with
    | (t1::q1, t2::q2) -> 
138
	let c = X.compare t1 t2 in
139
140
141
142
143
144
	if c < 0 then disjoint q1 l2
	else if c > 0 then disjoint l1 q2
	else false
    | _ -> true
	
let rec cup l1 l2 =
145
  if l1 == l2 then l1 else
146
147
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
148
	let c = X.compare t1 t2 in
149
150
151
152
153
154
155
156
157
158
159
	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) ->
160
	let c = X.compare t1 t2 in
161
162
163
164
165
166
167
	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 =
168
  if l1 == l2 then [] else
169
170
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
171
	let c = X.compare t1 t2 in
172
173
174
175
176
	if c = 0 then diff q1 q2
	else if c < 0 then t1::(diff q1 l2)
	else diff l1 q2
    | _ -> l1

177
178
let remove x l = diff l [x]

179
let rec cap l1 l2 =
180
  if l1 == l2 then l1 else
181
182
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
183
	let c = X.compare t1 t2 in
184
185
186
187
188
189
190
	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 =
191
  (l1 == l2) ||
192
193
  match (l1,l2) with
    | (t1::q1, t2::q2) ->
194
	let c = X.compare t1 t2 in
195
196
197
198
199
200
201
202
203
204
	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
	)
205
206
	else if c < 0 then false
	else subset l1 q2
207
    | [],_ -> true | _ -> false
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
	
	
	
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 -> 
231
        let c = X.compare x t in
232
233
234
        (c = 0) || ((c > 0) && (mem q x))

let rec check = function
235
  | a::(b::_ as t) -> assert (X.compare a b < 0); check t
236
  | _ -> ()
237

238
239
240
241
242
243
244
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) ]

245
246
247
248
249
250
251
  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
252
	if c = 0 then (r := Some y; l) 
253
254
255
256
257
	else if c < 0 then a :: (assoc_remove_aux v r l)
	else raise Not_found
    | [] -> raise Not_found

  let assoc_remove v l =
258
    let r = ref None in
259
    let l = assoc_remove_aux v r l in
260
    match !r with Some x -> (x,l) | _ -> assert false
261

262
263
264
265
266
267
268
269
270
271
(* 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
    | [] -> []

272
273
274
275
276
277
278
279
280
281
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 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)

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
end

402
403
404
405
406
407
408
409
410
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