Diff from to

File cis.ml

(**
-   Compact integer sets.
-   Attention: integers must be strictly positive !
- *)
+   Cis : compact integer sets
+
+   This module implements compact integer sets, represented as a (custom) list
+   of integer intervals. Usual set operations are provided.
+   The advantage compared to ordered lists is that the actual size may be smaller
+   than the cardinal of a set when many elements are contiguous. Most set operations
+   are linear w.r.t. the size, not the cardinal.
+
+   Author: Sébastien Ferré <ferre@irisa.fr>
+*)

(* for test
*)

-type elt = int (* in fact only positive integers *)
+(* copied from module Common *)
+
+let fold_for : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
+  fun f a b e ->
+    let res = ref e in
+    for x = a to b do
+      res := f x !res
+    done;
+    !res
+
+let fold_for_down : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
+  fun f a b e ->
+    let res = ref e in
+    for x = a downto b do
+      res := f x !res
+    done;
+    !res
+
+(* end of copy *)
+
+type elt = int
+
+type t = Nil | Single of int * t | Interv of int * int * t
+      (** integers in decreasing order *)
+
+let memory_size l =
+  let rec aux acc = function
+    | Nil -> acc
+    | Single (_,l) -> aux (acc + 3) l
+    | Interv (_,_,l) -> aux (acc + 4) l
+  in
+  aux 1 l (* 1 for the root reference *)
+
+let compare x y = Pervasives.compare y x
+
+let max_elt : t -> int =
+  function
+    | Nil -> raise (Invalid_argument "Cis.max_elt: set is empty")
+    | Single (x,_) -> x
+    | Interv (xmax,_,_) -> xmax

-type t = int list
-      (** integers in decreasing order, and negative value to mark beginning of interval. *)
+let rec min_elt : t -> int =
+  function
+    | Nil -> raise (Invalid_argument "Cis.max: set is empty")
+    | Single (x,Nil) -> x
+    | Interv (_,xmin,Nil) -> xmin
+    | Single (_,l) -> min_elt l
+    | Interv (_,_,l) -> min_elt l

let step : t -> nil:(unit -> 'a) -> single:(int -> t -> 'a) -> interv:(int * int -> t -> 'a) -> 'a =
fun l ~nil ~single ~interv ->
match l with
-    | [] -> nil ()
-    | x::y::l' when x < 0 -> interv (-x,y) l'
-    | x::l' -> single x l';;
+    | Nil -> nil ()
+    | Single (x,l') -> single x l'
+    | Interv (x,y,l') -> interv (x,y) l';;

let cons_single : int -> t -> t =
fun x l ->
step l
-      ~nil:(fun () -> [x])
-      ~single:(fun x' l' -> assert (x > x'); if x=x'+1 then (-x)::x'::l' else x::l)
-      ~interv:(fun (xmax',xmin') l' -> assert (x > xmax'); if x=xmax'+1 then (-x)::xmin'::l' else x::l);;
+      ~nil:(fun () -> Single (x,Nil))
+      ~single:(fun x' l' -> (* assert (x > x');*) if x=x'+1 then Interv (x,x',l') else Single (x,l))
+      ~interv:(fun (xmax',xmin') l' -> (* assert (x > xmax');*) if x=xmax'+1 then Interv (x,xmin',l') else Single (x,l));;

let cons_interv : int * int -> t -> t =
fun (xmax,xmin) l ->
if xmax > xmin then
step l
-	~nil:(fun () -> [-xmax; xmin])
-	~single:(fun x' l' -> assert (xmin > x'); if xmin=x'+1 then (-xmax)::x'::l' else (-xmax)::xmin::l)
-	~interv:(fun (xmax',xmin') l' -> assert (xmin > xmax'); if xmin=xmax'+1 then (-xmax)::xmin'::l' else (-xmax)::xmin::l)
+	~nil:(fun () -> Interv (xmax, xmin, Nil))
+	~single:(fun x' l' -> (* assert (xmin > x');*) if xmin=x'+1 then Interv (xmax,x',l') else Interv (xmax,xmin,l))
+	~interv:(fun (xmax',xmin') l' -> (* assert (xmin > xmax');*) if xmin=xmax'+1 then Interv (xmax, xmin', l') else Interv (xmax,xmin,l))
else if xmin=xmax then (* inlining of 'cons_single xmin l' *)
step l
-	~nil:(fun () -> [xmin])
-	~single:(fun x' l' -> assert (xmin > x'); if xmin=x'+1 then (-xmin)::x'::l' else xmin::l)
-	~interv:(fun (xmax',xmin') l' -> assert (xmin > xmax'); if xmin=xmax'+1 then (-xmin)::xmin'::l' else xmin::l)
+	~nil:(fun () -> Single (xmin,Nil))
+	~single:(fun x' l' -> (* assert (xmin > x');*) if xmin=x'+1 then Interv (xmin,x',l') else Single (xmin,l))
+	~interv:(fun (xmax',xmin') l' -> (* assert (xmin > xmax');*) if xmin=xmax'+1 then Interv (xmin,xmin',l') else Single (xmin,l))
else (* xmin > xmax *) l;;

-let empty : t = [];;
+let rec append : t -> t -> t = (* assumes (min_elt l1) > (max_elt l2) *)
+  fun l1 l2 ->
+    if l2 = Nil
+    then l1
+    else
+      let m = max_elt l2 in
+      append_aux l1 (m,l2)
+and append_aux l1 (m,l2) =
+  match l1 with
+  | Nil -> l2
+  | Single (x,Nil) -> if x=m+1 then cons_single x l2 else Single (x,l2)
+  | Interv (xmax,xmin,Nil) -> if xmin=m+1 then cons_interv (xmax,xmin) l2 else Interv (xmax,xmin,l2)
+  | Single (x,l') -> Single (x, append_aux l' (m,l2))
+  | Interv (xmax,xmin,l') -> Interv (xmax, xmin, append_aux l' (m,l2))
+
+(* -------------------------- *)
+
+let empty : t = Nil;;

let is_empty : t -> bool =
-  fun l -> l = []
+  fun l -> l = Nil

let rec cardinal : t -> int =
fun l -> cardinal_aux 0 l
~interv:(fun (xmax,xmin) l_tail ->
(xmax >= e & e >= xmin) or (pred xmin > e & mem e l_tail));;

+let choose : t -> elt =
+  fun l ->
+    step l
+      ~nil:(fun () -> raise Not_found)
+      ~single:(fun x _ -> x)
+      ~interv:(fun (xmax,xmin) _ -> xmax);;
+
let singleton : elt -> t =
-  fun x -> [x]
+  fun x -> Single (x,Nil)

let rec add : int -> t -> t =
fun x l ->
for x = xmax downto xmin do proc x done;
iter proc l_tail);;

-let rec fold : ('a -> elt -> 'a) -> 'a -> t -> 'a =
+let rec fold_left : ('a -> elt -> 'a) -> 'a -> t -> 'a =
fun f e l ->
step l
~nil:(fun () -> e)
~single:(fun x l_tail ->
-	fold f (f e x) l_tail)
+	fold_left f (f e x) l_tail)
+      ~interv:(fun (xmax,xmin) l_tail ->
+	fold_left f (fold_for_down (fun x res -> f res x) xmax xmin e) l_tail);;
+
+let rec fold_right : (elt -> 'a -> 'a) -> t -> 'a -> 'a =
+  fun f l e ->
+    step l
+      ~nil:(fun () -> e)
+      ~single:(fun x l_tail ->
+	f x (fold_right f l_tail e))
~interv:(fun (xmax,xmin) l_tail ->
-	fold f (Common.fold_for_down (fun x res -> f res x) xmax xmin e) l_tail);;
+	fold_for (fun x res -> f x res) xmin xmax (fold_right f l_tail e));;

let rec elements : t -> elt list =
fun l ->
-    fold (fun res x -> x::res) [] l;;
+    List.rev (fold_left (fun res x -> x::res) [] l);;

(* test section *)