# Commits

committed 3915c77

• Participants
• Parent commits 0cccbd7

# avlTree.ml

`+(* \$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`

# bintree.ml

`+(***********************************************************************)`
`+(*                                                                     *)`
`+(*                           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`

# cis-array.ml

`+(**`
`+   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.mli

`+(**`
`+   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. *)`

# common.old.ml

`+(* 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`

# dcg/essai.ml

`+`
`+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;;`

# dcg/essai2.ml

`+`
`+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)")`

# dcg/makefile

`+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]`

# dcg/msg.ml

`+(*`
`+ * 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`

# diet.ml

`+(*`
`+   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`

# diet.mli

`+(*`
`+   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)`

# dietset.ml

`+(***********************************************************************)`
`+(*                                                                     *)`
`+(*  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"`

# flist.ml

`+(**`
`+   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`
`+`

# gdbm/dbm.ml

`+(***********************************************************************)`
`+(*                                                                     *)`
`+(*                           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)`

# gdbm/dbm.mli

`+(***********************************************************************)`
`+(*                                                                     *)`
`+(*                           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. *)`
`+`

# gdbm/essai.ml

`+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"`

# genid.ml

`+`
`+(** {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`

# genmap.ml

`+`
`+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`