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 append : t -> t -> t
(* val cardinal : t -> int *)
val empty : t
val inter : 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
(* UNSAFE
module PathCis =
(* BEWARE: sensitive to changes in Cis *)
struct
(*
type elt = int
type t = Cis.t
*)
include Cis
let from_lset l =
List.fold_left
(fun res x -> add x res)
empty
(List.rev l)
(* let is_empty = Cis.is_empty *)
let compare_head xs ys = compare (max_elt xs) (max_elt ys)
(* let empty = Cis.empty *)
(* let append = Cis.append *)
(* let iter = Cis.iter *)
let rec tail xs ys =
(* assert (not (is_empty ys)); *)
let y = max_elt ys in
tail2 xs y
and tail2 xs y =
step xs
~nil:(fun () -> empty)
~single:(fun x l' ->
let c = compare x y in
if c < 0
then tail2 l' y
else xs)
~interv:(fun (xmax,xmin) l' ->
let cmin = compare xmin y in
if cmin < 0
then tail2 l' y
else
let cmax = compare xmax y in
if cmax < 0
then cons_interv (y,xmin) l'
else xs)
let rec rev l =
rev_aux empty l
and rev_aux acc l =
step l
~nil:(fun () -> acc)
~single:(fun x l -> rev_aux (cons_single x acc) l)
~interv:(fun (xmax,xmin) l -> rev_aux (cons_interv (xmax,xmin) acc) l)
(*
let rec rev l =
rev_aux Nil l
and rev_aux acc = function
| Nil -> acc
| Single (x,l) -> rev_aux (Single (x,acc)) l
| Interv (xmax,xmin,l) -> rev_aux (Interv (xmax,xmin,acc)) l
*)
let rec prefix_zip xs ys =
prefix_zip_aux empty xs ys
and prefix_zip_aux acc xs ys =
let base () = rev acc, xs, ys in
step xs
~nil:base
~single:(fun x1 l1 ->
step ys
~nil:base
~single:(fun x2 l2 ->
if x1 = x2 then prefix_zip_aux (cons_single x1 acc) l1 l2 else base ())
~interv:(fun (xmax2, xmin2) l2 ->
if x1 = xmax2 then
let l2' = cons_interv (xmax2-1,xmin2) l2 in
rev (cons_single x1 acc), l1, l2'
else base ()))
~interv:(fun (xmax1,xmin1) l1 ->
step ys
~nil:base
~single:(fun x2 l2 ->
if xmax1 = x2 then
let l1' = cons_interv (xmax1-1,xmin1) l1 in
rev (cons_single x2 acc), l1', l2
else base ())
~interv:(fun (xmax2,xmin2) l2 ->
if xmax1 = xmax2 then
let c = Cis.compare xmin1 xmin2 in
if c = 0 then
prefix_zip_aux (cons_interv (xmax1,xmin1) acc) l1 l2
else if c < 0 then
let l2' = cons_interv (xmin1-1,xmin2) l2 in
rev (cons_interv (xmax1,xmin1) acc), l1, l2'
else (* c > 0 *)
let l1' = cons_interv (xmin2-1,xmin1) l1 in
rev (cons_interv (xmax2,xmin2) acc), l1', l2
else base ()))
let rec prefix_inter xs ys =
prefix_inter_aux Nil xs ys
and prefix_inter_aux =
fun acc l1 l2 ->
step l1
~nil:(fun () -> l1, rev acc)
~single:(fun x1 l1_tail ->
step l2
~nil:(fun () -> l1, rev acc)
~single:(fun x2 l2_tail ->
if x1 > 1+x2 then prefix_inter_aux acc l1_tail l2
else if x2 > 1+x1 then prefix_inter_aux acc l1 l2_tail
else if x1 = 1+x2 then prefix_inter_aux acc l1_tail l2_tail
else if x2 = 1+x1 then prefix_inter_aux acc l1_tail l2_tail
else (* x1=x2 *) prefix_inter_aux (Single (x1,acc)) l1_tail l2_tail)
~interv:(fun (xmax2,xmin2) l2_tail ->
if x1 > xmax2 then prefix_inter_aux acc l1_tail l2
else if xmin2 > x1 then prefix_inter_aux acc l1 l2_tail
else (* xmax2 >= x1 & x1 >= xmin2 *) prefix_inter_aux (Single (x1,acc)) l1_tail l2))
~interv:(fun (xmax1,xmin1) l1_tail ->
step l2
~nil:(fun () -> l1, rev acc)
~single:(fun x2 l2_tail ->
if x2 > xmax1 then prefix_inter_aux acc l1 l2_tail
else if xmin1 > x2 then prefix_inter_aux acc l1_tail l2
else (* xmax1 >= x2 & x2 >= xmin1 *) prefix_inter_aux (Single (x2,acc)) l1 l2_tail)
~interv:(fun (xmax2,xmin2) l2_tail ->
if xmin2 > xmax1 then prefix_inter_aux acc l1 l2_tail
else if xmin1 > xmax2 then prefix_inter_aux acc l1_tail l2
else
let xmax, xmin = min xmax1 xmax2, max xmin1 xmin2 in
let acc' = if xmax = xmin then Single (xmax,acc) else Interv (xmax,xmin,acc) in
if xmin1 >= xmin2 then prefix_inter_aux acc' l1_tail l2 else prefix_inter_aux acc' l1 l2_tail))
end
*)
module PathLSet (* : PATH with type elt = int *) =
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 append l1 l2 = l1 @ l2
let cardinal = LSet.cardinal
let empty = []
let singleton = LSet.singleton
let add = LSet.add
let inter = LSet.inter
let fold_right = LSet.fold_right
let fold_left = LSet.fold_left
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 cardinal (l,e) = LSet.cardinal l
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 ->
(* assert (not (Path.is_empty ys)); *)
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) ->
(* assert (not (Path.is_empty ys1)); *)
(* assert (not (Path.is_empty ys2)); *)
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 = (* assert (not (Path.is_empty ys)); *) 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)