Source

ocaml-lib / setrie.ml

Diff from to

setrie.ml

 
     val is_empty : t -> bool
     val compare_head : t -> t -> int
-    val empty : t
     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_inter : t -> t -> t * t
   end
 
-module PathLSet : PATH with type elt = int and type t = int LSet.t =
+(* 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 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 append =  (@)
+    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
 
       | _, [] -> xs0, (List.rev s)
   end
 
+(*
 module PathLSetLast : PATH with type elt = int =
   struct
     type elt = int
     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) =
       | [], _ -> [], (List.rev s,e)
       | _, [] -> xs0, (List.rev s,e)
   end
+*)
 
 module Make (Path : PATH) =
   struct
 	  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
       | 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
       | Some v -> f ys v ys'
 	    
 
-    let rec mapmin_inter : (Path.t -> 'b -> 'b option) -> 'b t -> Path.t -> 'b t =
+    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
+	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' =
+    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
+	      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
+		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
+	  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
+	      (*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'
+	      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 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'
 		  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
+		  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' =
+    and mapmin_inter_vopt f vopt (*ys'*) =
       match vopt with
       | None -> None
-      | Some v -> f ys' v
+      | Some v -> f (*ys'*) v
 	    
   end