Source

ocaml-lib / setrie.ml

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 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
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
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
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441

module type PATH =
  sig
    type elt
    type t

    val from_lset : elt LSet.t -> t

    val is_empty : t -> bool
    val compare_head : t -> t -> int
    val empty : t
    val append : t -> t -> t
    val iter : (elt -> unit) -> t -> unit

    val tail : t -> t -> t
    val prefix_zip : t -> t -> t * t * t
    val prefix_inter : t -> t -> t * t
  end

module PathLSet : PATH with type elt = int and type t = int LSet.t =
  struct
    type elt = int
    type t = elt LSet.t

    let from_lset l = l

    let is_empty l = l = []

    let compare_head xs ys =
      LSet.compare (List.hd xs) (List.hd ys)

    let empty = []

    let append =  (@)

    let iter = List.iter

    let rec tail xs ys =
      let y = List.hd ys in
      tail2 xs y
    and tail2 xs y =
      match xs with
      | [] -> []
      | x::xs1 ->
	  let c = LSet.compare x y in
	  if c < 0
	  then tail2 xs1 y
	  else xs

    let rec prefix_zip xs ys =
      prefix_zip_aux [] (xs,ys)
    and prefix_zip_aux p = function
      | x::xs1, y::ys1 when x=y ->
	  prefix_zip_aux (x::p) (xs1,ys1)
      | xs, ys ->
	  (List.rev p), xs, ys

    let rec prefix_inter xs ys =
      prefix_inter_aux [] (xs,ys)
    and prefix_inter_aux s (xs0,ys0) =
      match xs0, ys0 with
      | x::xs, y::ys ->
	  let c = LSet.compare x y in
	  if c = 0 then prefix_inter_aux (y::s) (xs,ys)
	  else if c < 0 then prefix_inter_aux s (xs,ys0)
	  else (* c > 0 *) prefix_inter_aux s (xs0,ys)
      | [], _ -> [], (List.rev s)
      | _, [] -> xs0, (List.rev s)
  end

module PathLSetLast : PATH with type elt = int =
  struct
    type elt = int
    type t = elt LSet.t * elt

    let rec last = function
      | [] -> 0
      | [e] -> e
      | e::l -> last l

    let from_lset l = l, last l

    let is_empty (l,e) = l = []

    let compare_head (xs,ex) (ys,ey) =
      LSet.compare (List.hd xs) (List.hd ys)

    let empty = [], 0

    let append (l1,e1) (l2,e2) =
      if l2 = [] then (l1,e1) else (l1@l2,e2)

    let iter f (l,e) = List.iter f l

    let rec tail (xs,ex) (ys,ey) =
      if xs = []
      then [], 0
      else
	let y = List.hd ys in
	let c = LSet.compare ex y in
	if c < 0 then [], 0
	else if c = 0 then [ex], ex
	else tail2 xs (List.hd ys), ex
    and tail2 xs y =
      match xs with
      | [] -> []
      | x::xs1 ->
	  let c = LSet.compare x y in
	  if c < 0
	  then tail2 xs1 y
	  else xs

    let rec prefix_zip (xs,ex) (ys,ey) =
      let prefix, xs', ys' = prefix_zip_aux ([],0) (xs,ys) in
      prefix, (xs',ex), (ys',ey)
    and prefix_zip_aux (p,e) = function
      | x::xs1, y::ys1 when x=y ->
	  prefix_zip_aux (x::p,x) (xs1,ys1)
      | xs, ys ->
	  (List.rev p,e), xs, ys

    let rec prefix_inter (xs,ex) (ys,ey) =
      let c = LSet.compare (List.hd xs) ey in
      if c > 0 then (xs,ex), ([],0)
      else if c = 0 then (List.tl xs,ex), ([ey],ey)
      else (* c < 0 *)
	let xs', yse' = prefix_inter_aux ([],0) (xs,ys) in
	(xs',ex), yse'
    and prefix_inter_aux (s,e) (xs0,ys0) =
      match xs0, ys0 with
      | x::xs, y::ys ->
	  let c = LSet.compare x y in
	  if c = 0 then prefix_inter_aux (y::s,y) (xs,ys)
	  else if c < 0 then prefix_inter_aux (s,e) (xs,ys0)
	  else (* c > 0 *) prefix_inter_aux (s,e) (xs0,ys)
      | [], _ -> [], (List.rev s,e)
      | _, [] -> xs0, (List.rev s,e)
  end

module Make (Path : PATH) =
  struct
    type 'b tree = Node of Path.t * 'b option * 'b tree * 'b tree | Nil
      (* Node (path, value at path, elder child, next brother), to be specialized (?) when child and/or brother are Nil *)

    type 'b t = 'b option * 'b tree (* (vopt, tree) ~ Node ([], vopt, tree, Nil) *)
	  (* tree, and value associated to the empty set *)

    let make_branch ys vopt child =
      if Path.is_empty ys
      then vopt, child
      else None, Node (ys, vopt, child, Nil)

    let rec first_vopt = function
      | [] -> None
      | None::l -> first_vopt l
      | Some v::l -> Some v


(* main interface *)
(* -------------- *)

    let rec fold : (Path.t -> 'b -> 'c -> 'c) -> 'b t -> 'c -> 'c =
      fun f (vopt,t) e ->
	let e1 = match vopt with None -> e | Some v -> f Path.empty v e in
	fold2 f t e1 Path.empty
    and fold2 f t e ys0 =
      match t with
      | Nil -> e
      | Node (ys, vopt, child, brother) ->
	  let ys' = Path.append ys0 ys in
	  let e1 = match vopt with None -> e | Some v -> f ys' v e in
	  let e2 = fold2 f child e1 ys' in
	  let e3 = fold2 f brother e2 ys0 in
	  e3


    let empty : 'b t = None, Nil

    let rec cardinal : 'b t -> int =
      fun (vopt,tree) ->
	cardinal_vopt vopt + cardinal2 tree
    and cardinal2 = function
      | Nil -> 0
      | Node (_,vopt,child,brother) ->
	  cardinal_vopt vopt + cardinal2 child + cardinal2 brother
    and cardinal_vopt = function
      | None -> 0
      | Some _ -> 1

    let singleton : Path.t -> 'b -> 'b t =
      fun xs v ->
	if Path.is_empty xs
	then Some v, Nil
	else None, Node (xs, Some v, Nil, Nil)

    let rec add : ('b -> 'b -> 'b) ->  Path.t -> 'b -> 'b t -> 'b t =
      fun u xs v (vopt,t) ->
	if Path.is_empty xs
	then add_vopt u vopt v, t
	else
	  match t with
	  | Nil -> vopt, Node (xs, Some v, Nil, Nil)
	  | Node (ys, vopt2, c2, b2) as tree ->
	      let c = Path.compare_head xs ys in
	      if c = 0 then
		let prefix, xs1', ys2' = Path.prefix_zip xs ys in
		let t2' = make_branch ys2' vopt2 c2 in
		let vopt', child' = add u xs1' v t2' in
		vopt, Node (prefix, vopt', child', b2)
	      else if c < 0 then
		vopt, Node (xs, Some v, Nil, tree)
	      else (* c > 0 *)
		let _, brother' = add u xs v (None, b2) in
		vopt, Node (ys, vopt2, c2, brother')
    and add_vopt u vopt v =
      match vopt with
      | None -> Some v
      | Some v0 -> Some (u v0 v)

    let rec remove : Path.t -> 'b t -> 'b t =
      fun xs (vopt,tree) ->
	if Path.is_empty xs
	then None, tree
	else vopt, remove2 xs tree
    and remove2 xs t =
      if Path.is_empty xs
      then t
      else
	match t with (* xs = x::xs1, ys = y::ys1 *)
	| Nil -> Nil
	| Node (ys, vopt, child, brother) ->
	    let c = Path.compare_head xs ys in
	    if c = 0 then
	      let prefix, xs1', ys1' = Path.prefix_zip xs ys in
	      if not (Path.is_empty ys1') then (* xs is not present *)
		t
	      else if Path.is_empty xs1' then (* vopt must be set to None *)
		if child = Nil then brother else Node (ys, None, child, brother)
	      else (* element to be removed is in child *)
		let child' = remove2 xs1' child in
		if vopt = None && child' = Nil then brother else Node (ys, vopt, child', brother)
	    else if c < 0 then (* xs is not present *)
	      t
	    else (* c > 0 *) (* xs is in b *)
	      let brother' = remove2 xs brother in
	      Node (ys, vopt, child, brother')

    let rec find : 'b t -> Path.t -> 'b = (* may raise Not_found *)
      fun (vopt,t) xs ->
	if Path.is_empty xs
	then find_vopt vopt
	else find2 t xs
    and find2 t xs =
      if Path.is_empty xs
      then raise Not_found
      else
	match t with
	| Nil -> raise Not_found
	| Node (ys, vopt, child, brother) ->
	    let c = Path.compare_head xs ys in
	    if c = 0 then
	      let prefix, xs1', ys1' = Path.prefix_zip xs ys in
	      if not (Path.is_empty ys1') then (* xs is not present *)
		raise Not_found
	      else if Path.is_empty xs1' then (* result is vopt *)
		find_vopt vopt
	      else (* result is in child *)
		find2 child xs1'
	    else if c < 0 then (* xs is not present *)
	      raise Not_found
	    else (* c > 0 *) (* xs is in brother *)
	      find2 brother xs
    and find_vopt = function
      | Some v -> v
      | None -> raise Not_found

    let rec union : ('b -> 'b -> 'b) -> 'b t -> 'b t -> 'b t =
      fun u (vopt1,tree1) (vopt2,tree2) ->
	union_vopt u vopt1 vopt2, union2 u tree1 tree2
    and union2 u t1 t2 =
      match t1, t2 with
      | Nil, _ -> t2
      | _, Nil -> t1
      | Node (ys1, vopt1, c1, b1), Node (ys2, vopt2, c2, b2) ->
	  let c = Path.compare_head ys1 ys2 in
	  if c = 0 then
	    let prefix, ys1', ys2' = Path.prefix_zip ys1 ys2 in
	    let t1' = make_branch ys1' vopt1 c1 in
	    let t2' = make_branch ys2' vopt2 c2 in
	    let vopt', child' = union u t1' t2' in
	    let brother' = union2 u b1 b2 in
	    Node (prefix, vopt', child', brother')
	  else if c < 0 then
	    Node (ys1, vopt1, c1, union2 u b1 t2)
	  else (* c > 0 *)
	    Node (ys2, vopt2, c2, union2 u t1 b2)
    and union_vopt u vopt1 vopt2 =
      match vopt1, vopt2 with
      | None, _ -> vopt2
      | _, None -> vopt1
      | Some v1, Some v2 -> Some (u v1 v2)

(* to be corrected
    let rec exists_contains : 'b t -> Path.t -> (Path.t -> 'b -> bool) -> bool =
      fun (vopt,t) xs p ->
	exists_contains_vopt vopt p Path.empty ||
	exists_contains2 t xs p Path.empty
    and exists_contains2 t xs p path =
      match t with
      | Nil -> false
      | Node (ys, vopt, child, brother) ->
	  if Path.is_empty xs
	  then
	    let path1 = Path.append path ys in
	    exists_contains_vopt vopt p path1 ||
	    exists_contains2 child xs p path1 ||
	    exists_contains2 brother xs p path
	  else
	    let c = Path.compare_head xs ys in
	    if c = 0 then
	      let xs', ys' = Path.prefix_inter xs ys in
	      if ys' = ys
	      then
		let path1 = Path.append path ys in
		exists_contains_vopt vopt p path1 ||
		exists_contains2 child xs' p path1
	      else false
	    else if c < 0 then false  (* head xs is missing *)
	    else (* c > 0 *)
	      let xs', ys' = Path.prefix_inter xs ys in
	      if ys' = ys (* NO!! *)
	      then
		let path1 = Path.append path ys in
		exists_contains_vopt vopt p path1 ||
		exists_contains2 child xs' p path1 ||
		exists_contains2 brother xs p path
	      else
		exists_contains2 brother xs p path
    and exists_contains_vopt vopt p path =
      match vopt with
      | None -> false
      | Some v -> p path v
*)

    let rec map_inter : (Path.t -> 'b -> Path.t -> 'b option) -> ('b -> 'b -> 'b) -> 'b t -> Path.t -> 'b t =
      fun f u (vopt,t) xs ->
	let vopt' = map_inter_vopt f vopt Path.empty Path.empty in
	let vopt'', t' = map_inter2 f u t xs Path.empty Path.empty in
	union_vopt u vopt' vopt'', t'
    and map_inter2 f u t xs path path' =
      match t with
      | Nil -> None, Nil
      | Node (ys, vopt, child, brother) ->
	  if Path.is_empty xs
	  then
	    let path1 = Path.append path ys in
	    let vopt' = map_inter_vopt f vopt path1 path' in
	    let child_vopt', _ (* Nil *) = map_inter2 f u child xs path1 path' in
	    let brother_vopt', _ (* Nil *) = map_inter2 f u brother xs path path' in
	    union_vopt u vopt' (union_vopt u child_vopt' brother_vopt'), Nil
	  else (* xs = x::xs1, ys = y::ys1 *)
	    let c = Path.compare_head xs ys in
	    if c = 0 then
	      let xs', ys' = Path.prefix_inter xs ys in
	      let path1, path1' = Path.append path ys, Path.append path' ys' in
	      let vopt' = map_inter_vopt f vopt path1 path1' in
	      let child_vopt', child' = map_inter2 f u child xs' path1 path1' in
	      let brother_vopt', brother' = map_inter2 f u brother xs path path' in
	      brother_vopt', Node (ys', union_vopt u child_vopt' vopt', child', brother')
	    else if c < 0 then
	      map_inter2 f u t (Path.tail xs ys) path path'
	    else (* c > 0 *)
	      let xs', ys' = Path.prefix_inter xs ys in
	      let path1, path1' = Path.append path ys, Path.append path' ys' in
	      let vopt' = map_inter_vopt f vopt path1 path1' in
	      let child_vopt', child' = map_inter2 f u child xs' path1 path1' in
	      let brother_vopt', brother' = map_inter2 f u brother xs path path' in
	      let t1 = make_branch ys' (union_vopt u vopt' child_vopt') child' in
	      let t2 = brother_vopt', brother' in
	      union u t1 t2
    and map_inter_vopt f vopt ys ys' =
      match vopt with
      | None -> None
      | Some v -> f ys v ys'
	    

    let rec mapmin_inter : (Path.t -> 'b -> 'b option) -> 'b t -> Path.t -> 'b t =
      fun f (vopt,t) xs ->
	let child_vopt, t' = mapmin_inter2 f t xs Path.empty in
	let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) Path.empty in
	vopt', t'
    and mapmin_inter2 f t xs path' =
      match t with
      | Nil -> None, Nil
      | Node (ys, vopt, child, brother) ->
	  if Path.is_empty xs
	  then
	    let return_vopt =
	      let brother_vopt, _ (* Nil *) = mapmin_inter2 f brother xs path' in
	      if brother_vopt <> None then brother_vopt
	      else if vopt <> None then vopt
	      else
		let child_vopt, _ (* Nil *) = mapmin_inter2 f child xs path' in
		child_vopt in
	    return_vopt, Nil
	  else 
	    let c = Path.compare_head xs ys in
	    if c = 0 then
	      let xs', ys' = Path.prefix_inter xs ys in (* we know that ys' is not empty *)
	      let path1' = Path.append path' ys' in
	      let child_vopt, child' = mapmin_inter2 f child xs' path1' in
	      let brother_vopt, brother' = mapmin_inter2 f brother xs path' in
	      let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) path1' in
	      brother_vopt, Node (ys', vopt', child', brother')
	    else if c < 0 then
	      mapmin_inter2 f t (Path.tail xs ys) path'
	    else (* c > 0 *)
	      let xs', ys' = Path.prefix_inter xs ys in (* ys' may be empty *)
	      let path1' = Path.append path' ys' in
	      let child_vopt, child' = mapmin_inter2 f child xs' path1' in
	      let brother_vopt, brother' = mapmin_inter2 f brother xs path' in
	      let t1 =
		let vopt1 = first_vopt [vopt; child_vopt] in
		if Path.is_empty ys'
		then
		  let return_vopt = if brother_vopt = None then vopt1 else None in
		  return_vopt, child'
		else
		  let vopt' = mapmin_inter_vopt f vopt1 path1' in
		  None, Node (ys', vopt', child', Nil) in
	      let t2 = brother_vopt, brother' in
	      union (fun _ v2 -> v2) t1 t2
    and mapmin_inter_vopt f vopt ys' =
      match vopt with
      | None -> None
      | Some v -> f ys' v
	    
  end


module Default = Make (PathLSet)