Sébastien Ferré avatar Sébastien Ferré committed 3915c77

Addition of ML source files.

Comments (0)

Files changed (38)

+(* $Id: avlTree.ml,v 1.2 2003/06/08 04:50:48 yori Exp $ *)
+(* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *)
+
+type 'a tree = Empty | Node of 'a tree * 'a * 'a tree * int
+
+let empty = Empty
+
+let is_empty = function Empty -> true | _ -> false
+
+let singleton_tree x = Node (Empty, x, Empty, 1)
+
+let left_branch = function
+    Empty -> raise Not_found
+  | Node (l, _, _, _) -> l
+
+let right_branch = function
+    Empty -> raise Not_found
+  | Node (_, _, r, _) -> r
+
+let root = function
+    Empty -> raise Not_found
+  | Node (_, v, _, _) -> v
+
+let height = function
+    Empty -> 0
+  | Node (_, _, _, h) -> h
+
+let create l v r =
+  let h' = 1 + max (height l) (height r) in
+  Node (l, v, r, h')
+
+let rec make_tree l v r =
+  let hl = height l in
+  let hr = height r in
+  if hl >= hr + 2 then
+    match l with
+      Empty -> assert false
+    | Node (ll, u, lr, _) ->
+	create ll u (make_tree lr v r)
+  else if hr >= hl + 2 then
+    match r with
+      Empty -> assert false
+    | Node (rl, u, rr, _) ->
+	create (make_tree l v rl) u rr
+  else
+    create l v r
+
+(* Utilities *)
+let rec split_leftmost = function
+    Empty -> raise Not_found
+  | Node (Empty, v, r, _) -> (v, r)
+  | Node (l, v, r, _) ->
+      let v0, l' = split_leftmost l in
+      (v0, make_tree l' v r)
+
+let rec split_rightmost = function
+    Empty -> raise Not_found
+  | Node (l, v, Empty, _) -> (v, l)
+  | Node (l, v, r, _) ->
+      let v0, r' = split_rightmost r in
+      (v0, make_tree l v r')
+
+let rec concat t1 t2 =
+  match t1, t2 with
+    Empty, _ -> t2
+  | _, Empty -> t1
+  | Node (l1, v1, r1, h1), Node (l2, v2, r2, h2) ->
+      if h1 < h2 then
+	make_tree (concat t1 l2) v2 r2
+      else
+	make_tree l1 v1 (concat r1 t2)
+
+let rec iter proc = function
+    Empty -> ()
+  | Node (l, v, r, _) ->
+      iter proc l;
+      proc v;
+      iter proc r
+
+let rec fold f t init =
+  match t with
+    Empty -> init
+  | Node (l, v, r, _) ->
+      let x = fold f l init in
+      let x = f v x in
+      fold f r x
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: set.ml,v 1.18 2004/04/23 10:01:54 xleroy Exp $ *)
+
+type 'a t = Empty | Node of 'a t * 'a * 'a t * int
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+let height = function
+    Empty -> 0
+  | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value v and right son r.
+       We must have all elements of l < v < all elements of r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+let create l v r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced and | height l - height r | <= 3.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+let bal l v r =
+  let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+  let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+  if hl > hr + 2 then begin
+    match l with
+      Empty -> invalid_arg "Set.bal"
+    | Node(ll, lv, lr, _) ->
+        if height ll >= height lr then
+          create ll lv (create lr v r)
+        else begin
+          match lr with
+            Empty -> invalid_arg "Set.bal"
+          | Node(lrl, lrv, lrr, _)->
+              create (create ll lv lrl) lrv (create lrr v r)
+        end
+  end else if hr > hl + 2 then begin
+    match r with
+      Empty -> invalid_arg "Set.bal"
+    | Node(rl, rv, rr, _) ->
+        if height rr >= height rl then
+          create (create l v rl) rv rr
+        else begin
+          match rl with
+            Empty -> invalid_arg "Set.bal"
+          | Node(rll, rlv, rlr, _) ->
+              create (create l v rll) rlv (create rlr rv rr)
+        end
+  end else
+    Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+      
+    (* Insertion of one element *)
+
+let rec add x = function
+    Empty -> Node(Empty, x, Empty, 1)
+  | Node(l, v, r, _) as t ->
+      let c = Pervasives.compare x v in
+      if c = 0 then t else
+      if c < 0 then bal (add x l) v r else bal l v (add x r)
+	
+    (* Same as create and bal, but no assumptions are made on the
+       relative heights of l and r. *)
+
+let rec join l v r =
+  match (l, r) with
+    (Empty, _) -> add v r
+  | (_, Empty) -> add v l
+  | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
+      if lh > rh + 2 then bal ll lv (join lr v r) else
+      if rh > lh + 2 then bal (join l v rl) rv rr else
+      create l v r
+	
+    (* Smallest and greatest element of a set *)
+
+let rec min_elt = function
+    Empty -> raise Not_found
+  | Node(Empty, v, r, _) -> v
+  | Node(l, v, r, _) -> min_elt l
+	
+let rec max_elt = function
+    Empty -> raise Not_found
+  | Node(l, v, Empty, _) -> v
+  | Node(l, v, r, _) -> max_elt r
+
+    (* Remove the smallest element of the given set *)
+
+let rec remove_min_elt = function
+    Empty -> invalid_arg "Set.remove_min_elt"
+  | Node(Empty, v, r, _) -> r
+  | Node(l, v, r, _) -> bal (remove_min_elt l) v r
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assume | height l - height r | <= 2. *)
+
+let merge t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2)
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       No assumption on the heights of l and r. *)
+
+let concat t1 t2 =
+  match (t1, t2) with
+    (Empty, t) -> t
+  | (t, Empty) -> t
+  | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2)
+	
+    (* Splitting.  split x s returns a triple (l, present, r) where
+        - l is the set of elements of s that are < x
+        - r is the set of elements of s that are > x
+        - present is false if s contains no element equal to x,
+          or true if s contains an element equal to x. *)
+
+let rec split x = function
+    Empty ->
+      (Empty, false, Empty)
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then (l, true, r)
+      else if c < 0 then
+        let (ll, pres, rl) = split x l in (ll, pres, join rl v r)
+          else
+        let (lr, pres, rr) = split x r in (join l v lr, pres, rr)
+	  
+    (* Implementation of the set operations *)
+
+let empty = Empty
+    
+let is_empty = function Empty -> true | _ -> false
+    
+let rec mem x = function
+    Empty -> false
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      c = 0 || mem x (if c < 0 then l else r)
+
+let rec find x = function
+  | Empty -> raise Not_found
+  | Node (l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then v
+      else if c < 0 then find x l
+      else (* c > 0 *) find x r
+	    
+let singleton x = Node(Empty, x, Empty, 1)
+    
+let rec remove x = function
+    Empty -> Empty
+  | Node(l, v, r, _) ->
+      let c = Pervasives.compare x v in
+      if c = 0 then merge l r else
+      if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+	    
+let rec union s1 s2 =
+  match (s1, s2) with
+    (Empty, t2) -> t2
+  | (t1, Empty) -> t1
+  | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+      if h1 >= h2 then
+        if h2 = 1 then add v2 s1 else begin
+          let (l2, _, r2) = split v1 s2 in
+          join (union l1 l2) v1 (union r1 r2)
+        end
+      else
+        if h1 = 1 then add v1 s2 else begin
+          let (l1, _, r1) = split v2 s1 in
+          join (union l1 l2) v2 (union r1 r2)
+        end
+
+let rec inter s1 s2 =
+  match (s1, s2) with
+    (Empty, t2) -> Empty
+  | (t1, Empty) -> Empty
+  | (Node(l1, v1, r1, _), t2) ->
+      match split v1 t2 with
+        (l2, false, r2) ->
+          concat (inter l1 l2) (inter r1 r2)
+      | (l2, true, r2) ->
+          join (inter l1 l2) v1 (inter r1 r2)
+	    
+let rec diff s1 s2 =
+  match (s1, s2) with
+    (Empty, t2) -> Empty
+  | (t1, Empty) -> t1
+  | (Node(l1, v1, r1, _), t2) ->
+      match split v1 t2 with
+        (l2, false, r2) ->
+          join (diff l1 l2) v1 (diff r1 r2)
+      | (l2, true, r2) ->
+          concat (diff l1 l2) (diff r1 r2)
+
+type 'a enumeration = End | More of 'a * 'a t * 'a enumeration
+    
+let rec cons_enum s e =
+  match s with
+    Empty -> e
+  | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+	
+let rec compare_aux e1 e2 =
+  match (e1, e2) with
+    (End, End) -> 0
+  | (End, _)  -> -1
+  | (_, End) -> 1
+  | (More(v1, r1, e1), More(v2, r2, e2)) ->
+      let c = Pervasives.compare v1 v2 in
+      if c <> 0
+      then c
+      else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+	  
+let compare s1 s2 =
+  compare_aux (cons_enum s1 End) (cons_enum s2 End)
+    
+let equal s1 s2 =
+  compare s1 s2 = 0
+    
+let rec subset s1 s2 =
+  match (s1, s2) with
+    Empty, _ ->
+      true
+  | _, Empty ->
+      false
+  | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+      let c = Pervasives.compare v1 v2 in
+      if c = 0 then
+        subset l1 l2 && subset r1 r2
+      else if c < 0 then
+        subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+      else
+        subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+	  
+let rec iter f = function
+    Empty -> ()
+  | Node(l, v, r, _) -> iter f l; f v; iter f r
+	
+let rec fold f s accu =
+  match s with
+    Empty -> accu
+  | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+	
+let rec for_all p = function
+    Empty -> true
+  | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+
+let rec exists p = function
+    Empty -> false
+  | Node(l, v, r, _) -> p v || exists p l || exists p r
+      
+let filter p s =
+  let rec filt accu = function
+    | Empty -> accu
+    | Node(l, v, r, _) ->
+        filt (filt (if p v then add v accu else accu) l) r in
+  filt Empty s
+
+let partition p s =
+  let rec part (t, f as accu) = function
+    | Empty -> accu
+    | Node(l, v, r, _) ->
+        part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+  part (Empty, Empty) s
+
+let rec cardinal = function
+    Empty -> 0
+  | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+	
+let rec elements_aux accu = function
+    Empty -> accu
+  | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+	
+let elements s =
+  elements_aux [] s
+    
+let choose = min_elt
+(**
+   Compact integer sets.
+   Attention: integers must be strictly positive !
+ *)
+
+type t = int array
+      (** integers in decreasing order, and negative value to mark beginning of interval. *)
+
+let step : t * int -> nil:'a -> single:(int -> t * int -> 'a) -> interv:(int * int -> t * int -> 'a) -> 'a =
+  fun (ar,i) ~nil ~single ~interv ->
+    if i >= Array.length ar
+    then nil
+    else
+      let x = ar.(i) in
+      if x < 0
+      then interv (-x,ar.(i+1)) (ar,i+2)
+      else single x (ar,i+1)
+
+type e = Single of int | Interv of int * int | Ar of (t * int)
+
+type l = e list
+      (* in a list, there is at most one Ar element, and it must be the last. *)
+
+
+let rec cons : e -> l -> l =
+  fun e -> function
+    | [] -> [e]
+    | e'::l' as l ->
+	match e with
+	| Single x -> 
+	    ( match e' with
+	    | Single x' -> if x=x'+1 then Interv (x,x')::l' else e::l
+	    | Interv (xmax',xmin') -> if x=xmax'+1 then Interv (x,xmin')::l' else e::l
+	    | Ar (ari) ->
+		step ari
+		  ~nil:[e]
+		  ~single:(fun x' ari' -> if x=x'+1 then Interv (x,x')::Ar ari'::l' else e::l)
+		  ~interv:(fun (xmax',xmin') ari' -> if x=xmax'+1 then Interv (x,xmin')::Ar ari'::l' else e::l))
+	| Interv (xmax,xmin) ->
+	    if xmin > xmax then l
+	    else if xmin=xmax then cons (Single xmin) l
+	    else
+	      ( match e' with
+	      | Single x' -> if xmin=x'+1 then Interv (xmax,x')::l' else e::l
+	      | Interv (xmax',xmin') -> if xmin=xmax'+1 then Interv (xmax,xmin')::l' else e::l
+	      | Ar ari ->
+		  step ari
+		    ~nil:[e]
+		    ~single:(fun x' ari' -> if xmin=x'+1 then Interv (xmax,x')::Ar ari'::l' else e::l)
+		    ~interv:(fun (xmax',xmin') ari' -> if xmin=xmax'+1 then Interv (xmax,xmin')::Ar ari'::l' else e::l))
+	| Ar _ ->
+	    raise (Invalid_argument "Cis.cons: sub-arrays must be at the end of lists")
+
+let empty : t = Array.make 0 0
+
+let rec t_of_l : l -> t =
+  fun l ->
+    let size =
+      List.fold_left (fun res -> function Single _ -> res+1 | Interv _ -> res+2 | Ar (ar,i) -> res + (Array.length ar - i)) 0 l in
+    let ar = Array.make size 0 in
+    ignore (List.fold_left
+      (fun i -> function
+	| Single x -> (ar.(i) <- x); i+1
+	| Interv (xmax,xmin) -> (ar.(i) <- -xmax); (ar.(i+1) <- xmin); i+2
+	| Ar (ar',i') ->
+	    let nb_elt = Array.length ar' - i' in
+	    Array.blit ar' i' ar i nb_elt;
+	    i+nb_elt)
+      0
+      l);
+    ar
+
+let rec add : int -> t -> t =
+  fun x ar ->
+    if x <= 0 then raise (Invalid_argument "Cis.add: non-positive integer");
+    t_of_l (add_l x (ar,0))
+and add_l x ari =
+  step ari
+    ~nil:[Single x]
+    ~single:(fun x' ari' ->
+      if x > x' then cons (Single x) [Ar ari]
+      else if x = x' then [Ar ari]
+      else cons (Single x') (add_l x ari'))
+    ~interv:(fun (xmax',xmin') ari' ->
+      if x > xmax' then cons (Single x) [Ar ari]
+      else if xmax' >= x & x >= xmin' then [Ar ari]
+      else cons (Interv (xmax',xmin')) (add_l x ari'))
+
+
+let rec remove : int -> t -> t =
+  fun x ar ->
+    if x <= 0 then raise (Invalid_argument "Cis.remove: non-positive integer");
+    t_of_l (remove_l x (ar,0))
+and remove_l x ari =
+  step ari
+    ~nil:[]
+    ~single:(fun x' ari' ->
+      if x > x' then [Ar ari]
+      else if x = x' then [Ar ari']
+      else (* x' > x *) cons (Single x') (remove_l x ari'))
+    ~interv:(fun (xmax',xmin') ari' ->
+      if x > xmax' then [Ar ari]
+      else if xmax' >= x & x >= xmin' then cons (Interv (xmax',x+1)) (cons (Interv (x-1,xmin')) [Ar ari'])
+      else cons (Interv (xmax',xmin')) (remove_l x ari'))
+
+let from_list : int list -> t =
+  fun l ->
+    List.fold_right add l empty;;
+
+(*
+let rec inter : t -> t -> t =
+  fun ar1 ar2 ->
+    t_of_l (inter_l (ar1,0) (ar2,0))
+and inter_l ari1 ari2 =
+  step ari1
+    ~nil:[]
+    ~single:(fun x1 ari1_tail ->
+      step ari2
+	~nil:[]
+	~single:(fun x2 ari2_tail ->
+	  if x1 > x2 then inter_l ari1_tail ari2
+	  else if x2 > x1 then inter_l ari1 ari2_tail
+	  else (* x1=x2 *) cons (Single x1) (inter_l ari1_tail ari2_tail))
+	~interv:(fun (xmax2,xmin2) ari2' ->
+	  if x1 > xmax2 then inter_l ari1_tail ari2
+	  else if xmin2 > x1 then inter_l ari1 ari2_tail
+	  else (* xmax2 >= x & x >= xmin2 *) cons (Single x1) (inter_l ari1_tail ari2)))
+    ~interv:(fun (xmax1,xmin1) ari1' ->
+      step ari2
+	~nil:[]
+	~single:(fun x2 ari2_tail ->
+	  if x2 > xmax1 then inter_l ari1 ari2_tail
+	  else if xmin2 > x1 then inter_l ari1 ari2_tail
+	  else (* xmax2 >= x & x >= xmin2 *) cons (Single x1) (inter_l ari1_tail ari2))
+	~interv:(fun (xmax2,xmin2) ari2_tail ->
+	  if xmin2 > xmax1 then inter_l ari1 ari2_tail
+	  else if xmin1 > xmax2 then inter_l ari1_tail ari2
+	  else
+	    cons
+	      (Interv (min xmax1 xmax2,max xmin1 xmin2))
+	      (if xmin1 >= xmin2 then inter_l ari1_tail ari2 else inter_l ari1 ari2_tail)))
+
+*)
+
+
+let rec to_lset : t -> int LSet.t =
+  fun ar -> to_lset2 (ar,0)
+and to_lset2 (ari : t * int) : int LSet.t =
+  step ari
+    ~nil:(LSet.empty ())
+    ~single:(fun x ari' -> LSet.add x (to_lset2 ari'))
+    ~interv:(fun (xmax,xmin) ari' ->
+      Common.fold_for_down LSet.add xmax xmin (to_lset2 ari'));;
+
+
+(* test section *)
+
+#load "nums.cma"
+#load "str.cma"
+#load "unix.cma"
+#load "common.cmo"
+(*#load "lSet.cmo"*)
+
+let print_lset l =
+  List.iter (fun x -> print_int x; print_string " ") l;
+  print_newline ()
+
+let print_prof s =
+  try
+    let n, t, m = Hashtbl.find Common.tbl_prof s in
+    print_int n; print_string "\t";
+    print_float t; print_string "\t";
+    print_float m; print_string "\n"
+  with _ -> print_endline (s ^ " cannot be found in profiling")
+
+let rec random_list range =
+  function
+    | 0 -> []
+    | len ->
+	let x = 1 + Random.int range in
+	x::random_list range (len-1)
+
+let rec test range len1 len2 =
+  function
+    | 0 ->
+	print_prof "lset";
+	print_prof "cis"
+    | n ->
+	let l1 = random_list range len1 in
+
+(*	let ls1 = LSet.of_list l1 in
+	let ds1 = IntSet.from_list l1 in
+	let l2 = random_list range len2 in
+	let ls2 = LSet.of_list l2 in
+	let ds2 = IntSet.from_list l2 in
+*)
+	let ls = Common.prof "lset" (fun () -> LSet.of_list l1) in
+	let ds = Common.prof "cis" (fun () -> from_list l1) in
+	if to_lset ds <> ls
+	then begin
+(*
+	  print_lset ls1;
+	  print_lset ls2;
+*)
+	  print_lset ls;
+	  print_lset (to_lset ds) end
+	else test range len1 len2 (n-1)
+(**
+   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 of the structure, not the cardinal of the set.
+
+   Author: S�bastien Ferr� <ferre@irisa.fr>
+   License: LGPL
+*)
+
+type t (** Type of cis *)
+
+val max_elt : t -> int
+    (** [max_elt cis] returns the maximum integer in [cis]. Takes constant time. *)
+val min_elt : t -> int
+    (** [min_elt cis] returns the minimum integer in [cis]. Takes linear time. *)
+val step : t -> nil:(unit -> 'a) -> single:(int -> t -> 'a) -> interv:(int * int -> t -> 'a) -> 'a
+val cons_single : int -> t -> t
+val cons_interv : int * int -> t -> t
+val append : t -> t -> t
+    (** [append cis1 cis2] returns the union of [cis1] and [cis2] assuming that all elements of [cis1] are greater than any element of [cis2].
+       Takes linear time in the size of [cis1]. Not tail-recursive. *)
+val empty : t
+    (** [empty] is the empty set. *)
+val is_empty : t -> bool
+    (** [is_empty cis] returns whether [cis] is the empty set. *)
+val cardinal : t -> int
+    (** [cardinal cis] returns the cardinal of [cis]. Takes linear time in the size of [cis]. *)
+val mem : int -> t -> bool
+    (** [mem x cis] returns whether [x] belongs to [cis]. Takes linear time in the size of [cis]. *) 
+val choose : t -> int
+    (** [choose cis] returns an integer that belongs to [cis] if there is any, and raises [Not_found] otherwise. *)
+val singleton : int -> t
+    (** [singleton x] returns a singleton set with element [x]. *)
+val add : int -> t -> t
+    (** [add x cis] adds element [x] to [cis]. Takes linear time in the size of [cis], but constant time when [x] is greater than any element in [cis].
+       Not tail-recursive. *)
+val remove : int -> t -> t
+    (** [remove x cis] removes element [x] from [cis]. Not tail-recursive. *)
+val of_list : int list -> t
+    (** [of_list l] builds a cis from an integer list. *)
+val union : t -> t -> t
+    (** The set union. *)
+val inter : t -> t -> t
+    (** The set intersection. *)
+val diff : t -> t -> t
+    (** The set difference. *)
+val subset : t -> t -> bool
+    (** [subset cis1 cis2] returns whether [cis1] is a subset of [cis2]. *)
+val equal : t -> t -> bool
+    (** [equal cis1 cis2] returns whether [cis1] is equal to [cis2]. *)
+val iter : (int -> unit) -> t -> unit
+    (** Iteration on the elements of a cis. *)
+val fold_left : ('a -> int -> 'a) -> 'a -> t -> 'a
+    (** Left folding. Elements are visited in decreasing order. *)
+val fold_right : (int -> 'a -> 'a) -> t -> 'a -> 'a
+    (** Right folding. Integers are visited in increasing order. *)
+val elements : t -> int list
+    (** [elements cis] returns the elements of [cis] as list of decreasing integers. *)
+val memory_size : t -> int
+    (** [memory_size cis] returns the memory size of the set in words. *)
+(* time and space *)
+
+let utime () : float = (Unix.times ()).Unix.tms_utime (* in seconds *)
+
+let heap_size () : float = float_of_int (Gc.stat ()).Gc.heap_words *. float_of_int (Sys.word_size / 8)  (* in bytes *)
+
+(* extensions a Weak *)
+
+let weak_get_index : 'a Weak.t ref -> int =
+  fun w ->
+    let l = Weak.length !w in
+    let i = ref 0 in
+    while !i < l & Weak.check !w !i do incr i done;
+    if !i >= l then begin
+      let ar = Weak.create (l + 10)
+      in Weak.blit !w 0 ar 0 l; w := ar end;
+    !i
+
+let weak_add : 'a Weak.t ref -> 'a -> unit =
+  fun w x ->
+    let i = weak_get_index w in
+    Weak.set !w i (Some x)
+      
+let weak_iter : 'a Weak.t -> ('a -> unit) -> unit =
+  fun w f ->
+    for i=0 to Weak.length w - 1 do
+      match Weak.get w i with
+	None -> ()
+      | Some x -> f x
+    done
+
+let list_of_weak : 'a Weak.t -> 'a list =
+  fun w ->
+    let res = ref [] in
+    for i=0 to Weak.length w - 1 do
+      match Weak.get w i with
+	None -> ()
+      |	Some x -> res := x::!res
+    done;
+    !res
+
+(* List functionals *)
+(* ---------------- *)
+
+let rec mapfilter : ('a -> 'b option) -> 'a list -> 'b list =
+  fun f -> function
+      [] -> []
+    | x::l -> match f x with
+	None -> mapfilter f l
+      |	Some y -> y::mapfilter f l
+
+let rec mapfind : ('a -> 'b option) -> 'a list -> 'b =
+  fun f -> function
+  | [] -> raise Not_found
+  | x::l -> match f x with
+      | None -> mapfind f l
+      | Some y -> y
+
+let rec fold_while : ('a -> 'a option) -> 'a -> 'a =
+  fun f e ->
+    match f e with
+    | None -> e
+    | Some e' -> fold_while f e'
+
+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
+
+let rec fold_in_channel : ('b -> string -> 'b) -> 'b -> in_channel -> 'b =
+  fun f e ch ->
+    try fold_in_channel f (f e (input_line ch)) ch
+    with End_of_file -> e
+
+let rec insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list =
+  fun order x ->
+    function
+    | [] -> [x]
+    | y::ys ->
+       if order x y
+       then x::y::ys
+       else y::insert order x ys
+
+(* fold on all ordered pairs of a list *)
+let rec fold_pair : ('a -> 'a -> 'b -> 'b) -> 'a list -> 'b -> 'b =
+  fun f l e ->
+    match l with
+    | [] -> e
+    | x1::xs ->
+       List.fold_right
+         (fun x2 res -> f x1 x2 res)
+         xs
+         (fold_pair f xs e)
+
+let rec scramble : 'a list -> 'a list =
+  function
+  | [] -> []
+  | x::l ->
+     let l' = scramble l in
+     if Random.int 2 = 0
+     then x::l'
+     else l'@[x]
+
+let rec scrambles : 'a list -> int -> 'a list =
+  fun l -> function
+  | 0 -> l
+  | n -> scrambles (scramble l) (n-1)
+
+
+(* for profiling *)
+
+let tbl_prof : (string,(int * float * float)) Hashtbl.t = Hashtbl.create 100
+
+let prof : string -> (unit -> 'a) -> 'a =
+  fun s f ->
+(* print_string ("<"^s^":"); flush stdout; *)
+    let t1 = (Unix.times ()).Unix.tms_utime in
+    let m1 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
+    let y = f () in
+    let t2 = (Unix.times ()).Unix.tms_utime in
+    let m2 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
+    let n, t, m = try Hashtbl.find tbl_prof s with Not_found -> 0, 0., 0. in
+    Hashtbl.replace tbl_prof s (n+1, t +. (t2 -. t1), m +. (m2 -. m1));
+(* print_string (s^">\n"); flush stdout; *)
+    y
+
+(* probabilities *)
+
+open Num
+
+let comb_tbl : (int*int,num) Hashtbl.t = Hashtbl.create 10000
+let rec comb (k,n) =
+  if k > n or n < 0 then Int 0
+  else if k = n or k = 0 then Int 1
+  else if k > n / 2 then comb (n-k,n)
+  else
+    try Hashtbl.find comb_tbl (k,n)
+    with Not_found ->
+      let res = comb (k,n-1) +/ comb (k-1,n-1) in
+      Hashtbl.add comb_tbl (k,n) res;
+      res
+
+let chance_eq_num (r,w) (k,n) =
+  comb (k,r) */ comb (n-k,w-r) // comb (n,w)
+
+let chance_eq (r,w) (k,n) = prof "chance_eq" (fun () ->
+  float_of_num (chance_eq_num (r,w) (k,n)))
+
+let chance_ge_num (r,w) (k,n) =
+  let res = ref (Int 0) in
+  for i = k to n do
+    res := !res +/ chance_eq_num (r,w) (i,n)
+  done;
+  !res
+
+let chance_ge (r,w) (k,n) = prof "chance_ge" (fun () ->
+  float_of_num (chance_ge_num (r,w) (k,n)))
+
+
+(* mutex on global data structures *)
+
+    let m = Mutex.create ()
+
+    let owner = ref None
+
+    let mutex f =
+      match !owner with
+      | Some id when id = Thread.self () -> f ()
+      |	_ ->
+	  Mutex.lock m;
+	  owner := Some (Thread.self ());
+	  let res =
+            try f ()
+	    with e -> owner := None; Mutex.unlock m; raise e in
+	  owner := None;
+	  Mutex.unlock m;
+	  res
+
+(* utilities on streams *)
+
+let rec stream_map f = parser
+  | [<'x; str>] -> [<'f x; stream_map f str>]
+  | [<>] -> [<>]
+
+(* utilities on files *)
+
+(* found at http://pauillac.inria.fr/~remy/poly/system/camlunix/fich.html#toc13 *)
+let file_copy input_name output_name =
+  let buffer_size = 8192 in
+  let buffer = String.create buffer_size in
+  let fd_in = Unix.openfile input_name [Unix.O_RDONLY] 0 in
+  let fd_out = Unix.openfile output_name [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o666 in
+  let rec copy_loop () =
+    match Unix.read fd_in buffer 0 buffer_size with
+    | 0 -> ()
+    | r -> ignore (Unix.write fd_out buffer 0 r); copy_loop () in
+  copy_loop ();
+  Unix.close fd_in;
+  Unix.close fd_out
+
+let _ = Dcg.trace := true
+
+let skip = Str.regexp "[ \\\n\\\t\\\r]+"
+
+let p_ident = dcg "identifier" [ s = match "[a-zA-Z_][a-zA-Z_0-9]*" as "ident" when "invalid ident" not (List.mem x ["and"; "or"; "not"]) -> s ]
+let p_nat = dcg "natural" [ s = match "[0-9]+" -> int_of_string s ]
+let p_float = dcg "float" [ s = match "[0-9]+\\.[0-9]*" -> float_of_string s ]
+let p_string = dcg "string" [ s = match "\"[^\"]*\"" as "literal" -> String.escaped (String.sub s 1 (String.length s - 2)) ]
+
+
+type t = Atom of string | Literal of string | Not of t | And of t * t | Or of t * t
+
+let rec print = function
+  | Atom s -> s
+  | Literal s -> "\"" ^ s ^ "\""
+  | Not f -> "not " ^ print f
+  | And (f1,f2) -> "(" ^ print f1 ^ " and " ^ print f2 ^ ")"
+  | Or (f1,f2) -> "(" ^ print f1 ^ " or " ^ print f2 ^ ")"
+
+let p = dcg [
+  x = p_ident;
+  "and";
+  y = p_ident
+  -> And (Atom x, Atom y)
+]
+
+let rec parse = dcg "top" [
+  p = parse_or;
+  ( "and" then q = parse -> And (p,q)
+  | -> p
+  ) ]
+and parse_or = dcg [
+  p = parse_not;
+  ( "or" then q = parse_or -> Or (p,q)
+  | -> p
+  ) ]
+and parse_not = dcg [
+  | "not" then p = parse_atom -> Not p
+  | x = parse_atom -> x ]
+and parse_atom = dcg [
+  | "(" then p = parse; ")" -> p
+  | s = p_string -> Literal s
+  | x = p_ident -> Atom x ]
+
+let _, f = Dcg.once (dcg [ x = parse; EOF -> x ]) [] (Matcher.cursor_of_string skip "x and (\"y\" or not z)") in
+assert (f = And (Atom "x", Or (Literal "y", Not (Atom "z"))))
+
+let _, _ = Dcg.once (dcg [ EOF -> "" ]) [] (Matcher.cursor_of_string (Str.regexp "") "");;
+
+let rec parse_file = dcg "file"
+  [ f = parse_line then l = parse_file -> f::l
+  | EOF -> [] ]
+and parse_line = dcg "line"
+    [ f = parse; "." -> f ]
+
+let _, l = Dcg.once parse_file [] (Matcher.cursor_of_channel skip (open_in "essai.txt")) in
+List.iter (fun f -> print_endline (print f ^ ".")) l;;
+
+let skip = Str.regexp "[ \\\n\\\t\\\r]+"
+
+let p_ident = Matcher.get "identifier" (Str.regexp "[a-zA-Z_]\\([a-zA-Z_0-9]\\)*") (fun s -> Matcher.Token.repr s)
+let p_nat = Matcher.get "natural" (Str.regexp "[0-9]+") (fun s -> int_of_string (Matcher.Token.repr s))
+let p_float = Matcher.get "float" (Str.regexp "[0-9]+\\.[0-9]*") (fun s -> float_of_string (Matcher.Token.repr s))
+
+
+type t = Atom of string | Not of t | And of t * t | Or of t * t
+
+
+let p = dcg [< x = p_ident when x.[0] = 'a' ?? "x"; "and"; y = p_ident when y.[0] = 'b' ?? "b" >] -> And (Atom x, Atom y)
+
+let rec parse = dcg
+  | [< p = parse_or; f = parse_aux >] -> f p
+and parse_aux = dcg
+  | [< "and"; q = parse >] -> (fun p -> And (p, q))
+  | [<>] -> (fun p -> p)
+and parse_or = dcg
+  | [< p = parse_not; f = parse_or_aux >] -> f p
+and parse_or_aux = dcg
+  | [< "or"; q = parse_or >] -> (fun p -> Or (p,q))
+  | [<>] -> (fun p -> p)
+and parse_not = dcg
+  | [< "not"; p = parse_atom >] -> Not p
+  | [< p = parse_atom >] -> p
+and parse_atom = dcg
+  | [< "("; p = parse; ")" >] -> p
+  | [< x = p_ident >] -> Atom x
+
+let f = Dcg.once parse (Matcher.str_of_string skip "x and (y or not z)")
+OCAMLC=ocamlc
+INCLUDES=                # all relevant -I options here
+OCAMLFLAGS= $(INCLUDES)    # add other options for ocamlc here
+OCAMLDOCFLAGS= -d doc $(INCLUDES)
+
+# The list of object files
+OBJ = msg.cmo dcg.cmo matcher.cmo
+
+all: dcg.cma pa_dcg.cmo
+	echo
+
+dcg.cma: $(OBJ)
+	ocamlc $(OCAMLFLAGS) -a -o dcg.cma $(OBJ)
+	ocamlopt $(OCAMLFLAGS) -a -o dcg.cmxa $(OBJ:.cmo=.cmx)
+
+pa_dcg.cmo: pa_dcg.ml
+	ocamlc -I +camlp4 camlp4lib.cma -pp camlp4orf -c pa_dcg.ml
+
+essai.exe: essai.ml
+	ocamlc -o essai.exe -pp "camlp4o -I . pa_dcg.cmo" str.cma dcg.cma essai.ml
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi
+
+%.cmo: %.ml
+	ocamlc $(OCAMLFLAGS) -c $<
+	ocamlopt $(OCAMLFLAGS) -c $<
+
+# Documentationg
+html:
+	ocamldoc $(OCAMLDOCFLAGS) -html $(ALL:.cmo=.ml)
+
+# Clean up
+clean:
+	rm -f *.cm[ioax]
+	rm -f *.cmxa
+	rm -f *.[oa]
+(*
+ * Msg: parsing message module.
+ * Copyright (C) 2006
+ * Dmitri Boulytchev, St.Petersburg State University
+ * 
+ * This software is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public
+ * License version 2, as published by the Free Software Foundation.
+ * 
+ * This software is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ * 
+ * See the GNU Library General Public License version 2 for more details
+ * (enclosed in the file COPYING).
+ *)
+
+open Printf
+
+module Coord =
+  struct
+
+    type t = int * int
+
+    let toString (x, y) = sprintf "(%d:%d)" x y 
+   
+  end
+
+module Locator =
+  struct
+
+    type t = No | Point of Coord.t | Interval of Coord.t * Coord.t | Set of t list
+    and  l = t
+
+    let rec toString = function
+        | No              -> ""
+        | Point x         -> Coord.toString x
+        | Interval (x, y) -> sprintf "%s-%s" (Coord.toString x) (Coord.toString y)
+        | Set      x      -> String.concat ", " (List.map toString x)
+
+    let rec start = function
+      | No -> (1,1)
+      | Point coord -> coord
+      | Interval (c1,c2) -> c1
+      | Set [] -> (1,1)
+      | Set (x::_) -> start x
+
+  end
+
+type t = {phrase: string; args: string array; loc: Locator.t} 
+
+let make      phrase args loc = {phrase=phrase; args=args; loc=loc}
+let phrase    phrase          = make phrase [||] Locator.No
+let orphan    phrase args     = make phrase args Locator.No
+
+let string t = 
+  let parmExpr = Str.regexp "%\\([0-9]+\\)" in
+  Str.global_substitute 
+    parmExpr  
+    (fun s -> 
+      try 
+        t.args.(int_of_string (Str.replace_matched "\\1" s))
+      with
+      | Failure "int_of_string" -> 
+          raise (Failure 
+                   (sprintf "invalid integer parameter specification in message phrase \"%s\"" s)
+                )
+	    
+      | Invalid_argument "index out of bounds" ->
+          raise (Failure 
+                   (sprintf "index out of bound while accessing message parameter in \"%s\"" s)
+                )
+    )
+    t.phrase
+    
+let toString t =
+  let message = string t in
+    match Locator.toString t.loc with
+    | ""  -> message
+    | loc -> message ^ " at " ^ loc
+      
+let augment msg loc = match msg.loc with Locator.No -> {msg with loc = loc} | _ -> msg
+let augmentList msgs loc = List.map (fun x -> augment x loc) msgs

Binary file added.

+(*
+   Copyright � 2001, Olivier Andrieu.
+   Code licensed under GNU Library Public License (LGPL).
+
+   Implements Discrete Interval Encoding Tree (diet), a datastrucure 
+   for sets of integers.
+
+   Reference:
+     Martin Erwig.
+     Diets for Fat Sets.
+     Journal of Functional Programming, Vol. 8, No. 6, 627-632, 1998
+     http://www.cs.orst.edu/~erwig/papers/Diet_JFP98.pdf
+     http://www.cs.orst.edu/~erwig/diet/
+*)
+
+type t = | Empty | Node of int * int * t * t
+
+let empty = Empty
+
+let rec mem t v = 
+  match t with
+    | Empty -> false
+    | Node (x, _, l, _) when v < x ->
+	mem l v
+    | Node (_, y, _, r) when y < v ->
+	mem r v
+    | _ -> true
+
+let rec split_max = function
+  | Node (x, y, l, Empty) ->
+      (x, y, l)
+  | Node (x, y, l, r) ->
+      let (u, v, r') = split_max r in
+	(u, v, Node (x, y, l, r'))
+
+let join_left = function
+  | Node (_, _, Empty, _) as t -> t
+  | Node (x, y, l, r) as t ->
+      let (x', y', l') = split_max l in
+	if succ y' = x
+	then Node (x', y, l', r)
+	else t
+
+let rec split_min = function
+  | Node (x, y, Empty, r) ->
+      (x, y, r)
+  | Node (x, y, l, r) ->
+      let (u, v, l') = split_min l in
+	(u, v, Node (x, y, l', r))
+
+let join_right = function
+  | Node (_, _, _, Empty) as t -> t
+  | Node (x, y, l, r) as t ->
+      let (x', y', r') = split_min r in
+	if succ y = x'
+	then Node (x, y', l, r')
+	else t   
+
+let rec add t v =
+  match t with
+    | Empty -> 
+	Node (v, v, Empty, Empty)
+    | Node (x, y, l, r) when v < x ->
+	if succ v = x 
+	then join_left (Node (v, y, l, r))
+	else Node (x, y, add l v, r)
+    | Node (x, y, l, r) when y < v ->
+	if succ y = v
+	then join_right (Node (x, v, l, r))
+	else Node (x, y, l, add r v)
+    | t -> t
+
+let merge = function
+  | l, Empty -> l
+  | Empty, r -> r
+  | (l, r) ->
+      let (u, v, l') = split_max l in
+	Node (u, v, l', r)
+
+let rec remove t v = 
+  match t with
+    | Empty -> Empty
+    | Node (x, y, l, r) when v < x ->
+	Node (x, y, remove l v, r)
+    | Node (x, y, l, r) when y < v ->
+	Node (x, y, l, remove r v)
+    | Node (x, y, l, r) when v=x ->
+	if x=y
+	then merge (l, r)
+	else Node (succ x, y, l, r)
+    | Node (x, y, l, r) when v=y ->
+	Node (x, pred y, l, r)
+    | Node (x, y, l, r) ->
+	Node (x, pred v, l, Node (succ v, y, Empty, r))
+	  
+let rec iter f = function
+  | Empty -> ()
+  | Node (x, y, l, r) ->
+      iter f l ;
+      for i=x to y do f i done ;
+      iter f r
+
+let rec fold f i = function
+  | Empty -> i
+  | Node (x, y, l, r) ->
+      let il = fold f i l in
+      let tmp = ref il in
+	for j=x to y do
+	  tmp := f !tmp j 
+	done ;
+	fold f !tmp r
+
+
+
+(* ================================================== *)
+(*    FUNCTORIAL IMPLEMENTATION                       *)
+(* ================================================== *)
+
+module type ORD =
+  sig
+    type t
+    val compare : t -> t -> int
+    val pred : t -> t
+    val succ : t -> t
+  end
+
+module type DIET = 
+  sig
+    type elt
+    type t
+    val empty  : t
+    val mem    : t -> elt -> bool
+    val add    : t -> elt -> t
+    val remove : t -> elt -> t
+    val iter   : (elt -> unit) -> t -> unit
+    val fold   : ('a -> elt -> 'a) -> 'a -> t -> 'a
+  end
+
+module Make =
+  functor (O : ORD) ->
+  struct
+    type elt = O.t
+    type t = | Empty | Node of elt * elt * t * t
+
+    let empty = Empty
+
+    let rec mem t v = 
+      match t with
+      | Empty -> false
+      | Node (x, _, l, _) when O.compare v x < 0 ->
+	  mem l v
+      | Node (_, y, _, r) when O.compare v y > 0 ->
+	  mem r v
+      | _ -> true
+
+    let rec split_max = function
+      | Node (x, y, l, Empty) ->
+	  (x, y, l)
+      | Node (x, y, l, r) ->
+	  let (u, v, r') = split_max r in
+	  (u, v, Node (x, y, l, r'))
+
+    let join_left = function
+      | Node (_, _, Empty, _) as t -> t
+      | Node (x, y, l, r) as t ->
+	  let (x', y', l') = split_max l in
+	  if O.succ y' = x
+	  then Node (x', y, l', r)
+	  else t
+
+    let rec split_min = function
+      | Node (x, y, Empty, r) ->
+	  (x, y, r)
+      | Node (x, y, l, r) ->
+	  let (u, v, l') = split_min l in
+	  (u, v, Node (x, y, l', r))
+
+    let join_right = function
+      | Node (_, _, _, Empty) as t -> t
+      | Node (x, y, l, r) as t ->
+	  let (x', y', r') = split_min r in
+	  if O.succ y = x'
+	  then Node (x, y', l, r')
+	  else t   
+
+    let rec add t v =
+      match t with
+      | Empty -> 
+	  Node (v, v, Empty, Empty)
+      | Node (x, y, l, r) when O.compare v x < 0 ->
+	  if O.succ v = x 
+	  then join_left (Node (v, y, l, r))
+	  else Node (x, y, add l v, r)
+      | Node (x, y, l, r) when O.compare v y > 0 ->
+	  if O.succ y = v
+	  then join_right (Node (x, v, l, r))
+	  else Node (x, y, l, add r v)
+      | t -> t
+
+    let merge = function
+      | (l, Empty) -> l
+      | (Empty, r) -> r
+      | (l, r) ->
+	  let (u, v, l') = split_max l in
+	  Node (u, v, l', r)
+
+    let rec remove t v = 
+      match t with
+      | Empty -> Empty
+      | Node (x, y, l, r) when O.compare v x < 0 ->
+	  Node (x, y, remove l v, r)
+      | Node (x, y, l, r) when O.compare v y > 0 ->
+	  Node (x, y, l, remove r v)
+      | Node (x, y, l, r) when O.compare v x = 0 ->
+	  if x=y
+	  then merge (l, r)
+	  else Node (O.succ x, y, l, r)
+      | Node (x, y, l, r) when O.compare v y = 0 ->
+	  Node (x, O.pred y, l, r)
+      | Node (x, y, l, r) ->
+	  Node (x, O.pred v, l, Node (O.succ v, y, Empty, r))
+	  
+    let rec iter f = function
+      | Empty -> ()
+      | Node (x, y, l, r) ->
+	  iter f l ;
+	  let i = ref x in
+	  while O.compare !i y <> 0
+	  do 
+	    f !i ; 
+	    i := O.succ !i
+	  done ;
+	  iter f r
+
+    let rec fold f i = function
+      | Empty -> i
+      | Node (x, y, l, r) ->
+	  let il = fold f i l in
+	  let tmp = ref il in
+	  let j = ref x in
+	  while O.compare !j y <> 0
+	  do 
+	    tmp := f !tmp !j ;
+	    j := O.succ !j
+	  done ;
+	  fold f !tmp r
+  end
+(*
+   Copyright � 2001, Olivier Andrieu.
+   Code licensed under GNU Library Public License (LGPL).
+
+   Implements Discrete Interval Encoding Tree (diet), a datastrucure 
+   for sets of integers.
+
+   Reference:
+     Martin Erwig.
+     Diets for Fat Sets.
+     Journal of Functional Programming, Vol. 8, No. 6, 627-632, 1998
+     http://www.cs.orst.edu/~erwig/papers/Diet_JFP98.pdf
+     http://www.cs.orst.edu/~erwig/diet/
+*)
+
+(*TeX
+  Discrete Interval Encoding Tree is an efficient datastrucure 
+  for sets of integers. See \mbox{\texttt{<http://www.cs.orst.edu/~erwig/diet/>}}
+  and \mbox{\texttt{<http://www.cs.orst.edu/~erwig/papers/Diet_JFP98.pdf>}} for 
+  explanations on the algorithm.
+*)
+
+type t
+
+val empty  : t
+val mem    : t -> int -> bool
+val add    : t -> int -> t
+val remove : t -> int -> t
+val iter   : (int -> unit) -> t -> unit
+val fold   : ('a -> int -> 'a) -> 'a -> t -> 'a
+
+(*TeX
+  \paragraph{Functorial interface}
+  This datastructure can also be used with any type that is totally
+  ordered and with a predecessor and successor function.
+*)
+
+module type ORD =
+  sig
+    type t
+    val compare : t -> t -> int
+    val pred : t -> t
+    val succ : t -> t
+  end
+
+module type DIET = 
+  sig
+    type elt
+    type t
+    val empty  : t
+    val mem    : t -> elt -> bool
+    val add    : t -> elt -> t
+    val remove : t -> elt -> t
+    val iter   : (elt -> unit) -> t -> unit
+    val fold   : ('a -> elt -> 'a) -> 'a -> t -> 'a
+  end
+
+module Make :
+  functor (O : ORD) ->
+    (DIET with type elt = O.t)
+(***********************************************************************)
+(*                                                                     *)
+(*  Sebastien Ferre                                                    *)
+(*                                                                     *)
+(*  Copyright 2005 Universite de Rennes 1.  All rights reserved.       *)
+(*  This file is distributed under the terms of the GNU Library        *)
+(*  General Public License.                                            *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* Diet sets over ordered types with succ and pred operations *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+    val succ: t -> t
+    val pred: t -> t
+    val size: t -> t -> int
+  end
+
+module type S =
+  sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val max_elt: t -> elt
+    val choose: t -> elt
+    val split: elt -> t -> t * bool * t
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    type elt = Ord.t
+    type t = Empty | Node of t * elt * elt * t * int
+
+    let lt x y = Ord.compare x y < 0
+    let le x y = Ord.compare x y <= 0
+    let gt x y = Ord.compare x y > 0
+    let eq x y = Ord.compare x y = 0
+
+    (* Diet Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, _, h) -> h
+
+    (* Creates a new node with left son l, interval x y and right son r.
+       We must have all elements of l < x <= y < all elements of r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l x y r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      Node(l, x, y, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced and | height l - height r | <= 3.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l x y r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lx, ly, lr, _) ->
+            if height ll >= height lr then
+              create ll lx ly (create lr x y r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrx, lry, lrr, _)->
+                  create (create ll lx ly lrl) lrx lry (create lrr x y r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rx, ry, rr, _) ->
+            if height rr >= height rl then
+              create (create l x y rl) rx ry rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlx, rly, rlr, _) ->
+                  create (create l x y rll) rlx rly (create rlr rx ry rr)
+            end
+      end else
+        Node(l, x, y, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Returns the rightmost interval, and the tree less this interval *)
+
+    let rec split_max = function
+      | Node (l, x, y, Empty, _) ->
+	  (x, y, l)
+      | Node (l, x, y, r, _) ->
+	  let (u, v, r') = split_max r in
+	  (u, v, bal l x y r')
+      | Empty -> invalid_arg "Dietset.split_max"
+
+    (* Joins the root to its left interval, if necessary. *)
+
+    let rec join_left = function
+      | Empty as t -> t
+      | Node (Empty, _, _, _, _) as t -> t
+      | Node (l, x, y, r, _) as t ->
+	  let (x', y', l') = split_max l in
+	  if le (Ord.pred x) y'
+	  then
+	    if lt x x'
+	    then join_left (create l' x y r)
+	    else bal l' x' y r
+	  else t
+
+    (* Returns the leftmost interval, and the tree less this interval. *)
+
+    let rec split_min = function
+      | Node (Empty, x, y, r, _) ->
+	  (x, y, r)
+      | Node (l, x, y, r, _) ->
+	  let (u, v, l') = split_min l in
+	  (u, v, bal l' x y r)
+      | Empty -> invalid_arg "Dietset.split_min"
+
+    (* Joins the root to its right interval, if necessary. *)
+
+    let rec join_right = function
+      | Empty as t -> t
+      | Node (_, _, _, Empty, _) as t -> t
+      | Node (l, x, y, r, _) as t ->
+	  let (x', y', r') = split_min r in
+	  if le x' (Ord.succ y)
+	  then
+	    if lt y' y
+	    then join_right (create l x y r') 
+	    else bal l x y' r'
+	  else t
+
+    (* Insertion of an interval *)
+
+    let rec add_interv x0 y0 = function
+        Empty ->
+	  Node(Empty, x0, y0, Empty, 1)
+      | Node(l, x, y, r, h) as t ->
+	  if lt y0 (Ord.pred x) then
+	    bal (add_interv x0 y0 l) x y r
+	  else if lt (Ord.succ y) x0 then
+	    bal l x y (add_interv x0 y0 r)
+	  else
+	    if lt x0 x
+	    then
+	      if lt y y0
+	      then join_left (join_right (Node(l,x0,y0,r,h)))
+	      else join_left (Node(l,x0,y,r,h))
+	    else
+	      if lt y y0
+	      then join_right (Node(l,x,y0,r,h))
+	      else t
+
+    (* Same as create and bal, but no assumptions are made on the
+       relative heights of l and r. *)
+
+    let rec join l x y r =
+      match (l, r) with
+        (Empty, _) -> add_interv x y r
+      | (_, Empty) -> add_interv x y l
+      | (Node(ll, lx, ly, lr, lh), Node(rl, rx, ry, rr, rh)) ->
+          if lh > rh + 2 then bal ll lx ly (join lr x y r) else
+          if rh > lh + 2 then bal (join l x y rl) rx ry rr else
+          create l x y r
+
+    (* Smallest and greatest element of a set *)
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, x, y, r, _) -> x
+      | Node(l, x, y, r, _) -> min_elt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(l, x, y, Empty, _) -> y
+      | Node(l, x, y, r, _) -> max_elt r
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assume | height l - height r | <= 2. *)
+
+    let merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) ->
+	  let u, v, t2' = split_min t2 in
+	  bal t1 u v t2'
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       No assumption on the heights of l and r. *)
+
+    let concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (_, _) ->
+	  let u, v, t2' = split_min t2 in
+	  join t1 u v t2'
+
+    (* Splitting.  split x s returns a triple (l, present, r) where
+        - l is the set of elements of s that are < x
+        - r is the set of elements of s that are > x
+        - present is false if s contains no element equal to x,
+          or true if s contains an element equal to x. *)
+
+    let rec split f e x0 y0 = function
+        Empty ->
+          (Empty, e, Empty)
+      | Node(l, x, y, r, _) ->
+	  if lt y x0 then (* node on the left of (x0,y0) *)
+	    (* x <= y < x0 <= y0 *)
+	    let (rl,e',rr) = split f e x0 y0 r in
+	    (create l x y rl, e', rr)
+	  else if lt y0 x then (* node on the right of (x0,y0) *)
+	    (* x0 <= y0 < x <= y *)
+	    let (ll,e',lr) = split f e x0 y0 l in
+	    (ll, e', create lr x y r)
+	  else (* (x,y) and (x0,y0) overlap *)
+	    if lt x x0 then (* every node on the left of (x,y) is on the left of (x0,y0) *)
+	      if lt y0 y then (* every node on the right of (x,y) is on the right of (x0,y0) *)
+		(* x < x0 <= y0 < y *)
+		(create l x (Ord.pred x0) Empty, f x0 y0 e, create Empty (Ord.succ y0) y r)
+	      else begin
+		(* x < x0 <= y <= y0 *)
+		let (rl,e',rr) = split f e x0 y0 r in (* rl must be empty *)
+		(create l x (Ord.pred x0) Empty, f x0 y e', rr) end
+	    else
+	      if lt y0 y then begin (* every node on the right of (x,y) is on the right of (x0,y0) *)
+		(* x0 <= x <= y0 < y *)
+		let (ll,e',lr) = split f e x0 y0 l in (* lr must be empty *)
+		(ll, f x y0 e', create Empty (Ord.succ y0) y r) end
+	      else begin
+		(* x0 <= x <= y <= y0 *)
+		let (ll,e',lr) = split f e x0 y0 l in (* lr must be empty *)
+		let (rl,e'',rr) = split f e' x0 y0 r in (* rl must be empty *)
+		(ll, f x y e'', rr) end
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem v = function
+        Empty -> false
+      | Node(l, x, y, r, _) ->
+	  (* trick: (pred x) and (succ x) are not in the set *)
+	  let c1 = Ord.compare v (Ord.pred x) in
+	  if c1 < 0 then mem v l
+	  else
+	    let c2 = Ord.compare (Ord.succ y) v in
+	    if c2 < 0 then mem v r
+	    else c1 > 0 & c2 > 0
+
+    let singleton v = Node(Empty, v, v, Empty, 1)
+
+    let add v s = add_interv v v s
+
+    let rec remove v = function
+        Empty -> Empty
+      | Node(l, x, y, r, h) as t ->
+	  (* trick: (pred x) and (succ x) are not in the set *)
+	  let c1 = Ord.compare v (Ord.pred x) in
+	  if c1 < 0 then bal (remove v l) x y r
+	  else
+	    let c2 = Ord.compare (Ord.succ y) v in
+	    if c2 < 0 then bal l x y (remove v r)
+	    else if c1 > 0 & c2 > 0 then
+	      if eq v x then
+		if eq x y
+		then merge l r
+		else Node(l,Ord.succ x,y,r,h)
+	      else (* lt x v *)
+		if eq v y
+		then Node(l,x,Ord.pred y,r,h)
+		else join l x (Ord.pred v) (create Empty (Ord.succ v) y r)
+	    else t
+
+    let rec union2 s1 s2 =
+      match s1, s2 with
+      | (Empty, t2) -> t2
+      | (t1, Empty) -> t1
+      | (t1, Node(l2, x2, y2, r2, _)) ->
+	  union2 (add_interv x2 y2 (union2 t1 l2)) r2
+
+    let f_union x y () = () (*min x u, max y v*)
+    let rec union =
+      fun s1 s2 ->
+	match (s1, s2) with
+          (Empty, t2) -> t2
+	| (t1, Empty) -> t1
+	| (Node(l1, x1, y1, r1, h1), Node(l2, x2, y2, r2, h2)) ->
+            if h1 >= h2 then
+              if h2 = 1 then add_interv x2 y2 s1
+	      else begin
+		let (l2, _, r2) = split f_union () x1 y1 s2 in
+		(*match*) join_right (join_left (create (union l1 l2) x1 y1 (union r1 r2))) (*with
+		| Node (l, x, y, r, _) -> join l x y r
+		| Empty -> assert false*) end
+            else
+              if h1 = 1 then add_interv x1 y1 s2
+	      else begin
+		let (l1, _, r1) = split f_union () x2 y2 s1 in
+		(*match*) join_right (join_left (create (union l1 l2) x2 y2 (union r1 r2))) (*with
+		| Node (l, x, y, r, _) -> join l x y r
+		| Empty -> assert false*) end
+
+    let f_inter x y t : t = add_interv x y t
+    let rec inter =
+      fun s1 s2 ->
+	match (s1, s2) with
+          (Empty, t2) -> Empty
+	| (t1, Empty) -> Empty
+	| (Node(l1, x1, y1, r1, _), t2) ->
+	    let (l2, m2, r2) = split f_inter Empty x1 y1 t2 in
+	    merge (inter l1 l2) (merge m2 (inter r1 r2))
+
+    let f_diff x y () = ()
+    let rec diff =
+      fun s1 s2 ->
+	match (s1, s2) with
+          (Empty, t2) -> Empty
+	| (t1, Empty) -> t1
+	| (t1, Node(l2, x2, y2, r2, _)) ->
+	    let (l1, _, r1) = split f_diff () x2 y2 t1 in
+	    concat (diff l1 l2) (diff r1 r2)
+
+    let rec subset s1 s2 =
+      match (s1, s2) with
+        Empty, _ ->
+          true
+      | _, Empty ->
+          false
+      | Node (l1, x1, y1, r1, _), (Node (l2, x2, y2, r2, _) as t2) ->
+	  if le x2 x1 & le y1 y2 then
+	    (* x2 <= x1 <= y1 <= y2 *)
+	    subset l1 (Node (l2, x2, x1, Empty, 0)) & subset r1 (Node (Empty, y1, y2, r2, 0))
+	  else if lt y2 (Ord.pred x1) then
+	    (* x2 <= y2 < pred x1 <= y1 *)
+	    subset l1 t2 & subset (Node (Empty, x1, y1, r1, 0)) r2
+	  else if lt (Ord.succ y1) x2 then
+	    (* x1 <= succ y1 < x2 <= y2 *)
+	    subset (Node (l1, x1, y1, Empty, 0)) l2 & subset r1 t2
+	  else
+	    false
+
+    let rec iter_interv f x y =
+      if le x y then begin f x; iter_interv f (Ord.succ x) y end
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, x, y, r, _) -> iter f l; iter_interv f x y; iter f r
+
+    let rec fold_right_interv f x y accu =
+      if le x y
+      then fold_right_interv f x (Ord.pred y) (f y accu)
+      else accu
+
+    let rec fold_right f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, x, y, r, _) -> fold_right f l (fold_right_interv f x y (fold_right f r accu))
+
+    let rec fold_left_interv f accu x y =
+      if le x y
+      then fold_left_interv f (Ord.succ x) y (f accu x)
+      else accu
+
+    let rec fold_left f accu s =
+      match s with
+        Empty -> accu
+      | Node(l, x, y, r, _) -> fold_left f (fold_left_interv f (fold_left f accu l) x y) l
+
+(* TODO
+
+    let rec for_all p = function
+        Empty -> true
+      | Node(l, x, y, r, _) -> p v && for_all p l && for_all p r
+
+    let rec exists p = function
+        Empty -> false
+      | Node(l, v, r, _) -> p v || exists p l || exists p r
+
+    let filter p s =
+      let rec filt accu = function
+        | Empty -> accu
+        | Node(l, v, r, _) ->
+            filt (filt (if p v then add v accu else accu) l) r in
+      filt Empty s
+
+    let partition p s =
+      let rec part (t, f as accu) = function
+        | Empty -> accu
+        | Node(l, v, r, _) ->
+            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+      part (Empty, Empty) s
+
+TODO *)
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, x, y, r, _) -> cardinal l + Ord.size x y + cardinal r
+
+    let from_list l =
+      List.fold_left (fun res x -> add x res) empty l
+
+    let elements s =
+      fold_right (fun x xs -> x::xs) s []
+
+    let choose = min_elt
+
+  end
+
+module OrdInt =
+  struct
+    type t = int
+    let compare = compare
+    let succ = succ
+    let pred = pred
+    let size x y = y - x + 1
+  end
+
+module OSet = Set.Make(OrdInt)
+
+let set_of_list l =
+  List.fold_left (fun res x -> OSet.add x res) OSet.empty l;;
+
+module DietSet = Make(OrdInt)
+
+
+(* test section *)
+
+#load "nums.cma"
+#load "str.cma"
+#load "unix.cma"
+#load "common.cmo"
+#load "lSet.cmo"
+
+let print_lset l =
+  List.iter (fun x -> print_int x; print_string " ") l;
+  print_newline ()
+
+let print_prof s =
+  try
+    let n, t, m = Hashtbl.find Common.tbl_prof s in
+    print_int n; print_string "\t";
+    print_float t; print_string "\t";
+    print_float m; print_string "\n"
+  with _ -> print_endline (s ^ " cannot be found in profiling")
+
+let rec random_list range =
+  function
+    | 0 -> []
+    | len ->
+	let x = Random.int range in
+	x::random_list range (len-1)
+
+let rec test range len1 len2 n =
+  Hashtbl.clear Common.tbl_prof;
+  for i = 1 to n do
+    let l1 = random_list range len1 in
+    let ls1 = LSet.of_list l1 in
+    let os1 = set_of_list l1 in
+    let ds1 = DietSet.from_list l1 in
+    let l2 = random_list range len2 in
+    let ls2 = LSet.of_list l2 in
+    let os2 = set_of_list l2 in
+    let ds2 = DietSet.from_list l2 in
+    let ls = Common.prof "lset" (fun () -> LSet.union ls1 ls2) in
+    let os = Common.prof "oset" (fun () -> OSet.union os1 os2) in
+    let ds = Common.prof "dietset" (fun () -> DietSet.union ds1 ds2) in
+    if DietSet.elements ds <> ls
+    then begin
+      print_lset ls1;
+      print_lset ls2;
+      print_lset ls;
+      print_lset (DietSet.elements ds);
+      raise Not_found end
+  done;
+  print_prof "lset";
+  print_prof "oset";
+  print_prof "dietset"
+(**
+   Functional lists for efficient appending of lists.
+
+   Author: Sebastien Ferre
+*)
+
+
+type 'a flist = Cons of 'a * 'a flist | Nil | Rest of 'a flist ref
+
+type 'a t = 'a flist * 'a flist ref
+
+let nil () =
+  let r = ref Nil in
+  (Rest r, r)
+
+let cons x (l, r) = (Cons (x, l), r)
+
+let rec hd (l, r) =
+  match l with
+  | Nil -> raise (Invalid_argument "FList.hd")
+  | Cons (x, _) -> x
+  | Rest l_opt -> hd (!l_opt, r)
+
+let rec tl (l, r) =
+  match l with
+  | Nil -> raise (Invalid_argument "FList.tl")
+  | Cons (_, l) -> (l, r)
+  | Rest l_opt -> tl (!l_opt, r)
+
+let append (l1, r1) (l2, r2) =
+  r1 := l2;
+  (l1, r2)
+
+let rec fold_left f e (l, r) =
+  match l with
+  | Nil -> e
+  | Cons (x, l1) -> fold_left f (f e x) (l1, r)
+  | Rest l1_opt -> fold_left f e (!l1_opt, r) end
+
+let rec fold_right f (l, r) e =
+  match l with
+  | Nil -> e
+  | Cons (x, l1) -> f x (fold_right f (l1, r) e)
+  | Rest l1_opt -> fold_right f (!l1_opt, r) e end
+
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../../LICENSE.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: dbm.ml,v 1.10 2001/12/07 13:39:51 xleroy Exp $ *)
+
+type t
+
+type open_flag =
+   Dbm_rdonly | Dbm_wronly | Dbm_rdwr | Dbm_create
+
+type dbm_flag =
+   DBM_INSERT
+ | DBM_REPLACE
+
+exception Dbm_error of string
+
+external raw_opendbm : string -> open_flag list -> int -> t 
+              = "caml_dbm_open"
+
+let opendbm file flags mode =
+  try
+    raw_opendbm file flags mode
+  with Dbm_error msg ->
+    raise(Dbm_error("Can't open file " ^ file))
+
+ (* By exporting opendbm as val, we are sure to link in this
+    file (we must register the exception). Since t is abstract, programs
+    have to call it in order to do anything *)
+
+external close : t -> unit = "caml_dbm_close"
+external find : t -> string -> string = "caml_dbm_fetch"
+external add : t -> string -> string -> unit = "caml_dbm_insert"
+external replace : t -> string -> string -> unit = "caml_dbm_replace"
+external remove : t -> string -> unit = "caml_dbm_delete"
+external firstkey : t -> string = "caml_dbm_firstkey"
+external nextkey : t -> string = "caml_dbm_nextkey"
+
+let _ = Callback.register_exception "dbmerror" (Dbm_error "")
+
+(* Usual iterator *)
+let iter f t =
+  let rec walk = function
+      None -> ()
+    | Some k ->
+        f k (find t k); 
+        walk (try Some(nextkey t) with Not_found -> None)
+  in
+  walk (try Some(firstkey t) with Not_found -> None)
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../../LICENSE.  *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: dbm.mli,v 1.15 2001/12/07 13:39:51 xleroy Exp $ *)
+
+(** Interface to the NDBM database. *)
+
+type t
+(** The type of file descriptors opened on NDBM databases. *)
+
+
+type open_flag = 
+    Dbm_rdonly
+  | Dbm_wronly
+  | Dbm_rdwr
+  | Dbm_create
+(** Flags for opening a database (see {!Dbm.opendbm}). *)
+
+
+exception Dbm_error of string
+(** Raised by the following functions when an error is encountered. *)
+
+val opendbm : string -> open_flag list -> int -> t
+(** Open a descriptor on an NDBM database. The first argument is
+   the name of the database (without the [.dir] and [.pag] suffixes).
+   The second argument is a list of flags: [Dbm_rdonly] opens
+   the database for reading only, [Dbm_wronly] for writing only,
+   [Dbm_rdwr] for reading and writing; [Dbm_create] causes the
+   database to be created if it does not already exist.
+   The third argument is the permissions to give to the database
+   files, if the database is created. *)
+
+external close : t -> unit = "caml_dbm_close"
+(** Close the given descriptor. *)
+
+external find : t -> string -> string = "caml_dbm_fetch"
+(** [find db key] returns the data associated with the given
+   [key] in the database opened for the descriptor [db].
+   Raise [Not_found] if the [key] has no associated data. *)
+
+external add : t -> string -> string -> unit = "caml_dbm_insert"
+(** [add db key data] inserts the pair ([key], [data]) in
+   the database [db]. If the database already contains data
+   associated with [key], raise [Dbm_error "Entry already exists"]. *)
+
+external replace : t -> string -> string -> unit = "caml_dbm_replace"
+(** [replace db key data] inserts the pair ([key], [data]) in
+   the database [db]. If the database already contains data
+   associated with [key], that data is discarded and silently
+   replaced by the new [data]. *)
+
+external remove : t -> string -> unit = "caml_dbm_delete"
+(** [remove db key data] removes the data associated with [key]
+   in [db]. If [key] has no associated data, raise
+   [Dbm_error "dbm_delete"]. *)
+
+external firstkey : t -> string = "caml_dbm_firstkey"
+(** See {!Dbm.nextkey}.*)
+
+external nextkey : t -> string = "caml_dbm_nextkey"
+(** Enumerate all keys in the given database, in an unspecified order.
+   [firstkey db] returns the first key, and repeated calls
+   to [nextkey db] return the remaining keys. [Not_found] is raised
+   when all keys have been enumerated. *)
+
+val iter : (string -> string -> 'a) -> t -> unit
+(** [iter f db] applies [f] to each ([key], [data]) pair in
+   the database [db]. [f] receives [key] as first argument
+   and [data] as second argument. *)
+
+open Dbm
+
+let db = opendbm "dbessai.db" [Dbm_create; Dbm_rdwr] 0o660
+
+let _ =
+  print_endline "dbessai has been opened";
+  let s = String.make (1024*1024) 'a' in
+  for i = 1 to 3000 do
+    add db (string_of_int i) s;
+    if i mod 30 = 0 then begin print_int (i/30); print_endline "%"; flush stdout end
+  done;
+(*
+  for i = 1 to 100000 do
+    ignore (find db (string_of_int i))
+  done;
+*)
+  close db;
+  print_endline "dbessai has been closed"
+
+(** {1 Id Generator} *)
+
+open Persindex
+
+exception No_more_id
+
+class genid (name : string) (db : database) =
+  object (self)
+    val cpt : (unit,int) index = new var_atom (-1) (fun () -> 0) db
+    val all_free : (unit,int list) index = new var_opt_atom (fun () -> []) db
+
+    initializer
+      cpt # locate name name "cpt";
+      all_free # locate name name "all_free"
+
+    method name = name
+
+    method sync =
+      cpt # sync;
+      all_free # sync
+
+    method alloc =
+      match all_free # get () with
+      | [] ->
+	  let c = cpt # get () in
+	  if c < max_int
+	  then begin cpt # set () (c+1); c+1 end
+	  else raise No_more_id
+      | id::l ->
+	  all_free # set () l;
+	  id
+
+    method free id =
+      all_free # update () (fun l -> id::l)
+
+    method valid id =
+      id > 0 && id <= cpt # get () && not (List.mem id (all_free # get ()))
+  end
+
+module type T =
+  sig (* set operations refer to the set of keys of the map *)
+    type key
+    type 'a t
+    val cardinal : 'a t -> int
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val singleton : key -> unit t
+    val mem : key -> 'a t -> bool
+    val choose : 'a t -> key
+    val get : key -> 'a t -> 'a (* raise Not_found *)
+    val add : key -> unit t -> unit t
+    val set : key -> 'a -> 'a t -> 'a t
+    val remove : key -> 'a t -> 'a t
+
+    val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val domain : ?filter:(key -> 'a -> bool) -> 'a t -> unit t
+    val map : (key -> 'a -> 'b option) -> 'a t -> 'b t
+(*    val equal : ?filter:(key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool *)
+    val subset : ?filter:(key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> bool
+    val fold_inter : ('c -> key -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c
+    val domain_inter : ?filter:(key -> 'a -> 'b -> bool) -> 'a t -> 'b t -> unit t
+    val map_inter : (key -> 'a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t
+    val domain_union : ?filter:(key -> 'a option -> 'b option -> bool) -> 'a t -> 'b t -> unit t
+    val map_union : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val domain_diff : ?filter:(key -> 'a -> 'b option -> bool) -> 'a t -> 'b t -> unit t
+    val map_diff : (key -> 'a -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val memory_size : ?f:('a -> int) -> 'a t -> int (* in words, the argument function gives the memory size of a value *)
+  end
+
+let unit = (Obj.magic () : 'a)
+
+(* implementation based on Map for testing *)
+
+module Std (Key : sig type t val compare : t -> t -> int end) : T =
+  struct
+    module Map = Map.Make (Key) (*struct type t = int let compare = Pervasives.compare end*)
+
+    type key = Key.t
+    type 'a t = 'a Map.t
+
+    let cardinal m = Map.fold (fun _ _ res -> 1 + res) m 0
+    let empty = Map.empty
+    let is_empty = Map.is_empty
+    let choose m =
+      let x_opt = Map.fold (fun x _ _ -> Some x) m None in
+      match x_opt with
+      | None -> raise Not_found
+      | Some x -> x
+    let singleton x = Map.add x unit Map.empty
+    let mem = Map.mem
+    let get = Map.find
+    let add x m = Map.add x unit m
+    let set = Map.add
+    let remove = Map.remove
+    let fold f init m = Map.fold (fun x v res -> f res x v) m init
+    let iter = Map.iter
+
+    let domain ?(filter = fun _ _ -> true) m =
+      Map.fold
+	(fun x v res -> if filter x v then Map.add x unit res else res)
+	m Map.empty
+
+    let map f m =
+      Map.fold
+	(fun x v res -> match f x v with None -> res | Some v' -> Map.add x v' res)
+	m Map.empty
+
+    let subset ?(filter = fun _ _ _ -> true) m1 m2 =
+      Map.fold
+	(fun x v1 res -> res && try filter x v1 (Map.find x m2) with Not_found -> false)
+	m1 true
+
+    let fold_inter f init m1 m2 =
+      Map.fold
+	(fun x v1 res -> try f res x v1 (Map.find x m2) with Not_found -> res)
+	m1 init
+
+    let domain_inter ?(filter = fun _ _ _ -> true) m1 m2 =
+      Map.fold
+	(fun x v1 res -> try if filter x v1 (Map.find x m2) then Map.add x unit res else res with Not_found -> res)
+	m1 Map.empty
+
+    let map_inter f m1 m2 =
+      Map.fold
+	(fun x v1 res -> try match f x v1 (Map.find x m2) with None -> res | Some v -> Map.add x v res with Not_found -> res)
+	m1 Map.empty
+
+    let domain_union ?(filter = fun _ _ _ -> true) m1 m2 =
+      let m0 =
+	Map.fold
+	  (fun x v1 res ->
+	    if filter x (Some v1) (try Some (Map.find x m2) with Not_found -> None)
+	    then Map.add x unit res
+	    else res)
+	  m1 Map.empty in
+      Map.fold
+	(fun x v2 res ->
+	  if Map.mem x m1
+	  then res
+	  else
+	    if filter x (Some unit) (Some v2)
+	    then Map.add x unit res
+	    else res)
+	m2 m0
+      
+    let map_union f m1 m2 =
+      let m0 =
+	Map.fold
+	  (fun x v1 res ->
+	    match f x (Some v1) (try Some (Map.find x m2) with Not_found -> None) with
+	    | None -> res
+	    | Some v -> Map.add x v res)
+	  m1 Map.empty in
+      Map.fold
+	(fun x v2 res ->
+	  if Map.mem x m1
+	  then res
+	  else
+	    match f x (Some unit) (Some v2) with
+	    | None -> res
+	    | Some v -> Map.add x v res)
+	m2 m0
+      
+    let domain_diff ?(filter = fun _ _ v2_opt -> v2_opt = None) m1 m2 =
+      Map.fold
+	(fun x v1 res ->
+	  let v2_opt = try Some (Map.find x m2) with Not_found -> None in
+	  if filter x v1 v2_opt
+	  then Map.add x unit res
+	  else res)
+	m1 Map.empty
+
+    let map_diff f m1 m2 =
+      Map.fold
+	(fun x v1 res ->
+	  let v2_opt = try Some (Map.find x m2) with Not_found -> None in
+	  match f x v1 v2_opt with
+	  | None -> res
+	  | Some v -> Map.add x v res)
+	m1 Map.empty
+
+    let memory_size ?(f = fun _ -> 0) m = Map.fold (fun x v res -> 5 + f v + res) m 0
+  end
+
+(* ------------------------------------- *)
+
+module type KEY =
+  sig
+    type t
+    type level
+    val log : t -> level
+    val exp : level -> t
+    val div_mod : t -> t -> int * t
+	(* div_mod x base = q, r *)
+    val split : t -> level -> int * t
+	(* split x l = div_mod x (exp l) *)
+    val times_plus : int -> t -> t -> t
+	(* times_plus q base r = x *)
+    val merge : int -> level -> t -> t
+	(* merge q l r = times_plus q (exp l) r *)
+  end
+
+module KeyInt31 : KEY =
+  struct
+    type t = int
+    type level = int
+
+    (* table giving powers of 31 *)
+    let exp31 =
+      let res = Array.make 7 1 in
+      for i = 1 to 6 do
+	res.(i) <- 31 * res.(i-1)
+      done;
+      res
+
+    let log x =
+      let res = ref 6 in
+      while !res > 0 && x < exp31.(!res) do
+	decr res
+      done;
+      !res
+
+    let exp l = exp31.(l)
+