merge from master

Makefile

@@ -73,7 +73,7 @@ qtest: qtest-build
 	@echo 
 	./qtest_all.native
 
-push-stable: all
+push-stable:
 	git checkout stable
 	git merge master -m 'merge from master'
 	oasis setup

_oasis

@@ -47,7 +47,7 @@ Library "containers"
                     CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError,
                     CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
                     CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd,
-                    CCRandom, CCLinq, CCKTree, CCTrie, CCString
+                    CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl
   FindlibName:      containers
 
 Library "containers_string"
@@ -66,7 +66,7 @@ Library "containers_misc"
                     Bij, PiCalculus, Bencode, Sexp, RAL,
                     UnionFind, SmallSet, AbsSet, CSM,
                     ActionMan, BencodeOnDisk, TTree, PrintBox,
-                    HGraph, Automaton, Conv, Bidir, Iteratee,
+                    HGraph, Automaton, Conv, Bidir, Iteratee, BTree,
                     Ty, Tell, BencodeStream, RatTerm, Cause, AVL, ParseReact
   BuildDepends:     unix,containers
   FindlibName:      misc

core/CCArray.ml

@@ -68,6 +68,15 @@ module type S = sig
   (** [find f a] returns [Some y] if there is an element [x] such
       that [f x = Some y], else it returns [None] *)
 
+  val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option
+  (** Lookup the index of some value in a sorted array.
+      @return [None] if the key is not present, or
+        [Some i] ([i] the index of the key) otherwise *)
+
+  val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int
+  (** Same as {!lookup_exn}, but
+      @raise Not_found if the key is not present *)
+
   val for_all : ('a -> bool) -> 'a t -> bool
 
   val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
@@ -155,6 +164,31 @@ let rec _find f a i j =
     | Some _ as res -> res
     | None -> _find f a (i+1) j
 
+let rec _lookup_rec ~cmp k a i j =
+  if i>j then raise Not_found
+  else if i=j
+    then if cmp k a.(i) = 0
+      then i
+      else raise Not_found
+  else
+    let middle = (j+i)/2 in
+    match cmp k a.(middle) with
+    | 0 -> middle
+    | n when n<0 -> _lookup_rec ~cmp k a i (middle-1)
+    | _ -> _lookup_rec ~cmp k a (middle+1) j
+
+let _lookup_exn ~cmp k a i j =
+  if i>j then raise Not_found;
+  match cmp k a.(i) with
+  | 0 -> i
+  | n when n<0 -> raise Not_found (* too low *)
+  | _ when i=j -> raise Not_found (* too high *)
+  | _ ->
+      match cmp k a.(j) with
+      | 0 -> j
+      | n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1)
+      | _ -> raise Not_found  (* too high *)
+
 let rec _for_all p a i j =
   i = j || (p a.(i) && _for_all p a (i+1) j)
 
@@ -307,6 +341,23 @@ let flat_map f a =
   a' = [| 1; 2; 3; 4; 5; 6 |]
 *)
 
+let lookup_exn ?(cmp=Pervasives.compare) k a =
+  _lookup_exn ~cmp k a 0 (Array.length a-1)
+
+let lookup ?(cmp=Pervasives.compare) k a =
+  try Some (_lookup_exn ~cmp k a 0 (Array.length a-1))
+  with Not_found -> None
+
+(*$T
+  lookup 2 [|0;1;2;3;4;5|] = Some 2
+  lookup 4 [|0;1;2;3;4;5|] = Some 4
+  lookup 0 [|1;2;3;4;5|] = None
+  lookup 6 [|1;2;3;4;5|] = None
+  lookup 3 [| |] = None
+  lookup 1 [| 1 |] = Some 0
+  lookup 2 [| 1 |] = None
+*)
+
 let (>>=) a f = flat_map f a
 
 let for_all p a = _for_all p a 0 (Array.length a)
@@ -445,6 +496,13 @@ module Sub = struct
 
   let find f a = _find f a.arr a.i a.j
 
+  let lookup_exn ?(cmp=Pervasives.compare) k a =
+    _lookup_exn ~cmp k a.arr a.i (a.j-1)
+
+  let lookup ?(cmp=Pervasives.compare) k a =
+    try Some (_lookup_exn ~cmp k a.arr a.i (a.j-1))
+    with Not_found -> None
+
   let for_all p a = _for_all p a.arr a.i a.j
 
   let exists p a = _exists p a.arr a.i a.j

core/CCArray.mli

@@ -70,6 +70,15 @@ module type S = sig
   (** [find f a] returns [Some y] if there is an element [x] such
       that [f x = Some y], else it returns [None] *)
 
+  val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option
+  (** Lookup the index of some value in a sorted array.
+      @return [None] if the key is not present, or
+        [Some i] ([i] the index of the key) otherwise *)
+
+  val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int
+  (** Same as {!lookup_exn}, but
+      @raise Not_found if the key is not present *)
+
   val for_all : ('a -> bool) -> 'a t -> bool
 
   val for_all2 : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

core/CCError.ml

@@ -43,7 +43,20 @@ let return x = `Ok x
 
 let fail s = `Error s
 
-let of_exn e = `Error (Printexc.to_string e)
+let _printers = ref []
+
+let register_printer p = _printers := p :: !_printers
+
+let of_exn e =
+  let buf = Buffer.create 15 in
+  let rec try_printers l = match l with
+    | [] -> Buffer.add_string buf (Printexc.to_string e)
+    | p :: l' ->
+        try p buf e
+        with _ -> try_printers l'
+  in
+  try_printers !_printers;
+  `Error (Buffer.contents buf)
 
 let map f e = match e with
   | `Ok x -> `Ok (f x)
@@ -129,6 +142,37 @@ let fold_seq f acc seq =
 
 let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l)
 
+(** {2 Misc} *)
+
+let choose l =
+  let rec _find = function
+    | [] -> raise Not_found
+    | ((`Ok _) as res) :: _ -> res
+    | (`Error _) :: l' -> _find l'
+  in
+  try _find l
+  with Not_found ->
+    let buf = Buffer.create 32 in
+    (* print errors on the buffer *)
+    let rec print buf l = match l with
+      | `Ok _ :: _ -> assert false
+      | (`Error x)::((y::xs) as l) ->
+        Buffer.add_string buf x;
+        Buffer.add_string buf ", ";
+        print buf l
+      | `Error x::[] -> Buffer.add_string buf x
+      | [] -> ()
+    in
+    Printf.bprintf buf "CCError.choice failed: [%a]" print l;
+    fail (Buffer.contents buf)
+
+let rec retry n f = match n with
+  | 0 -> fail "retry failed"
+  | _ ->
+      match f () with
+      | `Ok _ as res -> res
+      | `Error _ -> retry (n-1) f
+
 (** {2 Monadic Operations} *)
 
 module type MONAD = sig
@@ -149,6 +193,14 @@ module Traverse(M : MONAD) = struct
   let fold_m f acc e = match e with
     | `Error s -> M.return acc
     | `Ok x -> f acc x >>= fun y -> M.return y
+
+  let rec retry_m n f = match n with
+    | 0 -> M.return (fail "retry failed")
+    | _ ->
+        let x = f () in
+        x >>= function
+        | `Ok _ -> x
+        | `Error _ -> retry_m (n-1) f
 end
 
 (** {2 Conversions} *)

core/CCError.mli

@@ -68,10 +68,15 @@ val fold : success:('a -> 'b) -> failure:(string -> 'b) -> 'a t -> 'b
 (** {2 Wrappers} *)
 
 val guard : (unit -> 'a) -> 'a t
+(** [guard f] runs [f ()] and returns its result wrapped in [`Ok]. If
+    [f ()] raises some exception [e], then it fails with [`Error msg]
+    where [msg] is some printing of [e] (see {!register_printer}). *)
 
 val wrap1 : ('a -> 'b) -> 'a -> 'b t
+(** Same as {!guard} but gives the function one argument. *)
 
 val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t
+(** Same as {!guard} but gives the function two arguments. *)
 
 val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t
 
@@ -89,6 +94,17 @@ val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t
 
 val fold_seq : ('b -> 'a -> 'b t) -> 'b -> 'a sequence -> 'b t
 
+(** {2 Misc} *)
+
+val choose : 'a t list -> 'a t
+(** [choose l] selects a member of [l] that is a [`Ok _] value,
+    or returns [`Error msg] otherwise, where [msg] is obtained by
+    combining the error messages of all elements of [l] *)
+
+val retry : int -> (unit -> 'a t) -> 'a t
+(** [retry n f] calls [f] at most [n] times, returning the first result
+    of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails. *)
+
 (** {2 Monadic Operations} *)
 module type MONAD = sig
   type 'a t
@@ -102,6 +118,8 @@ module Traverse(M : MONAD) : sig
   val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t
 
   val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t
+
+  val retry_m : int -> (unit -> 'a t M.t) -> 'a t M.t
 end
 
 (** {2 Conversions} *)
@@ -117,3 +135,21 @@ val to_seq : 'a t -> 'a sequence
 val pp : 'a printer -> 'a t printer
 
 val print : 'a formatter -> 'a t formatter
+
+(** {2 Global Exception Printers}
+
+One can register exception printers here, so they will be used by {!guard},
+{!wrap1}, etc. The printers should succeed (print) on exceptions they
+can deal with, and re-raise the exception otherwise. For instance
+if I register a printer for [Not_found], it could look like:
+  
+{[CCError.register_printer
+    (fun buf exn -> match exn with
+      | Not_found -> Buffer.add_string buf "Not_found"
+      | _ -> raise exn
+    );;
+]}
+This way a printer that doesn't know how to deal with an exception will
+let other printers do it. *)
+
+val register_printer : exn printer -> unit

core/CCFQueue.ml

@@ -37,9 +37,10 @@ type 'a digit =
   | Two of 'a * 'a
   | Three of 'a * 'a * 'a
 
+(* store the size in deep version *)
 type 'a t =
   | Shallow of 'a digit
-  | Deep of 'a digit * ('a * 'a) t lazy_t * 'a digit
+  | Deep of int * 'a digit * ('a * 'a) t lazy_t * 'a digit
 
 let empty = Shallow Zero
 
@@ -47,14 +48,17 @@ exception Empty
 
 let _single x = Shallow (One x)
 let _double x y = Shallow (Two (x,y))
-let _deep hd middle tl =
+let _deep n hd middle tl =
   assert (hd<>Zero && tl<>Zero);
-  Deep (hd, middle, tl)
+  Deep (n, hd, middle, tl)
 
 let is_empty = function
   | Shallow Zero -> true
   | _ -> false
 
+let singleton x = _single x
+let doubleton x y = _double x y
+
 let _empty = Lazy.from_val empty
 
 let rec cons : 'a. 'a -> 'a t -> 'a t
@@ -63,12 +67,12 @@ let rec cons : 'a. 'a -> 'a t -> 'a t
   | Shallow (One y) -> Shallow (Two (x,y))
   | Shallow (Two (y,z)) -> Shallow (Three (x,y,z))
   | Shallow (Three (y,z,z')) ->
-      _deep (Two (x,y)) _empty (Two (z,z'))
+      _deep 4 (Two (x,y)) _empty (Two (z,z'))
-  | Deep (Zero, middle, tl) -> assert false
+  | Deep (_, Zero, middle, tl) -> assert false
-  | Deep (One y, middle, tl) -> _deep (Two (x,y)) middle tl
+  | Deep (n,One y, middle, tl) -> _deep (n+1) (Two (x,y)) middle tl
-  | Deep (Two (y,z), middle, tl) -> _deep (Three (x,y,z)) middle tl
+  | Deep (n,Two (y,z), middle, tl) -> _deep (n+1)(Three (x,y,z)) middle tl
-  | Deep (Three (y,z,z'), lazy q', tail) ->
+  | Deep (n,Three (y,z,z'), lazy q', tail) ->
-      _deep (Two (x,y)) (lazy (cons (z,z') q')) tail
+      _deep (n+1) (Two (x,y)) (lazy (cons (z,z') q')) tail
 
 let rec snoc : 'a. 'a t -> 'a -> 'a t
   = fun q x -> match q with
@@ -76,12 +80,12 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t
   | Shallow (One y) -> Shallow (Two (y,x))
   | Shallow (Two (y,z)) -> Shallow (Three (y,z,x))
   | Shallow (Three (y,z,z')) ->
-      _deep (Two (y,z)) _empty (Two (z',x))
+      _deep 4 (Two (y,z)) _empty (Two (z',x))
-  | Deep (hd, middle, Zero) -> assert false
+  | Deep (_,hd, middle, Zero) -> assert false
-  | Deep (hd, middle, One y) -> _deep hd middle (Two(y,x))
+  | Deep (n,hd, middle, One y) -> _deep (n+1) hd middle (Two(y,x))
-  | Deep (hd, middle, Two (y,z)) -> _deep hd middle (Three(y,z,x))
+  | Deep (n,hd, middle, Two (y,z)) -> _deep (n+1) hd middle (Three(y,z,x))
-  | Deep (hd, lazy q', Three (y,z,z')) ->
+  | Deep (n,hd, lazy q', Three (y,z,z')) ->
-      _deep hd (lazy (snoc q' (y,z))) (Two(z',x))
+      _deep (n+1) hd (lazy (snoc q' (y,z))) (Two(z',x))
 
 let rec take_front_exn : 'a. 'a t -> ('a *'a t)
   = fun q -> match q with
@@ -89,17 +93,17 @@ let rec take_front_exn : 'a. 'a t -> ('a *'a t)
   | Shallow (One x) -> x, empty
   | Shallow (Two (x,y)) -> x, Shallow (One y)
   | Shallow (Three (x,y,z)) -> x, Shallow (Two (y,z))
-  | Deep (Zero, _, _) -> assert false
+  | Deep (_,Zero, _, _) -> assert false
-  | Deep (One x, lazy q', tail) ->
+  | Deep (n,One x, lazy q', tail) ->
       if is_empty q'
         then x, Shallow tail
         else
           let (y,z), q' = take_front_exn q' in
-          x, _deep (Two (y,z)) (Lazy.from_val q') tail
+          x, _deep (n-1)(Two (y,z)) (Lazy.from_val q') tail
-  | Deep (Two (x,y), middle, tail) ->
+  | Deep (n,Two (x,y), middle, tail) ->
-      x, _deep (One y) middle tail
+      x, _deep (n-1) (One y) middle tail
-  | Deep (Three (x,y,z), middle, tail) ->
+  | Deep (n,Three (x,y,z), middle, tail) ->
-      x, _deep (Two(y,z)) middle tail
+      x, _deep (n-1) (Two(y,z)) middle tail
 
 let take_front q =
   try Some (take_front_exn q)
@@ -127,15 +131,15 @@ let rec take_back_exn : 'a. 'a t -> 'a t * 'a
   | Shallow (One x) -> empty, x
   | Shallow (Two (x,y)) -> _single x, y
   | Shallow (Three (x,y,z)) -> Shallow (Two(x,y)), z
-  | Deep (hd, middle, Zero) -> assert false
+  | Deep (_, hd, middle, Zero) -> assert false
-  | Deep (hd, lazy q', One x) ->
+  | Deep (n, hd, lazy q', One x) ->
       if is_empty q'
         then Shallow hd, x
         else
           let q'', (y,z) = take_back_exn q' in
-          _deep hd (Lazy.from_val q'') (Two (y,z)), x
+          _deep (n-1) hd (Lazy.from_val q'') (Two (y,z)), x
-  | Deep (hd, middle, Two(x,y)) -> _deep hd middle (One x), y
+  | Deep (n, hd, middle, Two(x,y)) -> _deep (n-1) hd middle (One x), y
-  | Deep (hd, middle, Three(x,y,z)) -> _deep hd middle (Two (x,y)), z
+  | Deep (n, hd, middle, Three(x,y,z)) -> _deep (n-1) hd middle (Two (x,y)), z
 
 let take_back q =
   try Some (take_back_exn q)
@@ -171,6 +175,59 @@ let last q =
 
 let last_exn q = snd (take_back_exn q)
 
+let _size_digit = function
+  | Zero -> 0
+  | One _ -> 1
+  | Two _ -> 2
+  | Three _ -> 3
+
+let size : 'a. 'a t -> int
+  = function
+  | Shallow d -> _size_digit d
+  | Deep (n, _, _, _) -> n
+
+let _nth_digit i d = match i, d with
+  | _, Zero -> raise Not_found
+  | 0, One x -> x
+  | 0, Two (x,_) -> x
+  | 1, Two (_,x) -> x
+  | 0, Three (x,_,_) -> x
+  | 1, Three (_,x,_) -> x
+  | 2, Three (_,_,x) -> x
+  | _, _ -> raise Not_found
+
+let rec nth_exn : 'a. int -> 'a t -> 'a
+  = fun i q -> match i, q with
+  | _, Shallow Zero -> raise Not_found
+  | 0, Shallow (One x) -> x
+  | 0, Shallow (Two (x,_)) -> x
+  | 1, Shallow (Two (_,x)) -> x
+  | 0, Shallow (Three (x,_,_)) -> x
+  | 1, Shallow (Three (_,x,_)) -> x
+  | 2, Shallow (Three (_,_,x)) -> x
+  | _, Shallow _ -> raise Not_found
+  | _, Deep (n, l, q, r) ->
+      if i<_size_digit l
+      then _nth_digit i l
+      else
+        let i' = i - _size_digit l in
+        let q' = Lazy.force q in
+        if i'<2*size q'
+        then
+          let (x,y) = nth_exn (i'/2) q' in
+          if i' mod 2 = 0 then x else y
+        else
+          _nth_digit (i'-2*size q') r
+
+(*$T
+  let l = CCList.(0--100) in let q = of_list l in \
+    List.map (fun i->nth_exn i q) l = l
+*)
+
+let nth i q =
+  try Some (nth_exn i q)
+  with Failure _ -> None
+
 let init q =
   try fst (take_back_exn q)
   with Empty -> q
@@ -198,7 +255,7 @@ let _digit_to_seq d k = match d with
 let rec to_seq : 'a. 'a t -> 'a sequence
   = fun q k -> match q with
   | Shallow d -> _digit_to_seq d k
-  | Deep (hd, lazy q', tail) ->
+  | Deep (_, hd, lazy q', tail) ->
       _digit_to_seq hd k;
       to_seq q' (fun (x,y) -> k x; k y);
       _digit_to_seq tail k
@@ -218,21 +275,9 @@ let _map_digit f d = match d with
 let rec map : 'a 'b. ('a -> 'b) -> 'a t -> 'b t
   = fun f q -> match q with
   | Shallow d -> Shallow (_map_digit f d)
-  | Deep (hd, lazy q', tl) ->
+  | Deep (size, hd, lazy q', tl) ->
       let q'' = map (fun (x,y) -> f x, f y) q' in
-      _deep (_map_digit f hd) (Lazy.from_val q'') (_map_digit f tl)
+      _deep size (_map_digit f hd) (Lazy.from_val q'') (_map_digit f tl)
-
-let _size_digit = function
-  | Zero -> 0
-  | One _ -> 1
-  | Two _ -> 2
-  | Three _ -> 3
-
-let rec size : 'a. 'a t -> int
-  = function
-  | Shallow d -> _size_digit d
-  | Deep (hd, lazy q', tl) ->
-      _size_digit hd + 2 * size q' + _size_digit tl
 
 let (>|=) q f = map f q
 
@@ -245,7 +290,7 @@ let _fold_digit f acc d = match d with
 let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
   = fun f acc q -> match q with
   | Shallow d -> _fold_digit f acc d
-  | Deep (hd, lazy q', tl) ->
+  | Deep (_, hd, lazy q', tl) ->
       let acc = _fold_digit f acc hd in
       let acc = fold (fun acc (x,y) -> f (f acc x) y) acc q' in
       _fold_digit f acc tl
@@ -281,7 +326,7 @@ let to_klist q =
   let rec aux : 'a. 'a t -> 'a klist -> 'a klist
     = fun q cont () -> match q with
     | Shallow d -> _digit_to_klist d cont ()
-    | Deep (hd, lazy q', tl) ->
+    | Deep (_, hd, lazy q', tl) ->
         _digit_to_klist hd
           (_flat_klist
             (aux q' _nil)

core/CCFQueue.mli

@@ -38,6 +38,10 @@ val empty : 'a t
 
 val is_empty : 'a t -> bool
 
+val singleton : 'a -> 'a t
+
+val doubleton : 'a -> 'a -> 'a t
+
 exception Empty
 
 val cons : 'a -> 'a t -> 'a t
@@ -86,6 +90,13 @@ val first_exn : 'a t -> 'a
 
 val last_exn : 'a t -> 'a
 
+val nth : int -> 'a t -> 'a option
+(** Return the [i]-th element of the queue in logarithmic time *)
+
+val nth_exn : int -> 'a t -> 'a
+(** Unsafe version of {!nth}
+    @raise Not_found if the index is wrong *)
+
 val tail : 'a t -> 'a t
 (** Queue deprived of its first element. Does nothing on empty queues *)
 
@@ -105,7 +116,7 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 val (>|=) : 'a t -> ('a -> 'b) -> 'b t
 
 val size : 'a t -> int
-(** Number of elements in the queue (linear in time) *)
+(** Number of elements in the queue (constant time) *)
 
 val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
 

core/CCHashtbl.ml

@@ -0,0 +1,259 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+
+(** {1 Open-Addressing Hash-table}
+
+We use Robin-Hood hashing as described in
+http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/
+with backward shift. *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : int -> 'a t
+  (** Create a new table of the given initial capacity *)
+
+  val mem : 'a t -> key -> bool
+  (** [mem tbl k] returns [true] iff [k] is mapped to some value
+      in [tbl] *)
+
+  val find : 'a t -> key -> 'a option
+
+  val find_exn : 'a t -> key -> 'a
+
+  val get : key -> 'a t -> 'a option
+  (** [get k tbl] recovers the value for [k] in [tbl], or
+      returns [None] if [k] doesn't belong *)
+
+  val get_exn : key -> 'a t -> 'a
+
+  val add : 'a t -> key -> 'a -> unit
+  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
+      value associated with [k]. *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove binding *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+
+  val of_seq : (key * 'a) sequence -> 'a t
+  val to_seq : 'a t -> (key * 'a) sequence
+
+  val keys : _ t -> key sequence
+  val values : 'a t -> 'a sequence
+end
+
+module type HASHABLE = sig
+  type t
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module Make(X : HASHABLE) = struct
+  type key = X.t
+
+  type 'a bucket =
+    | Empty
+    | Key of key * 'a * int   (* store the hash too *)
+
+  type 'a t = {
+    mutable arr : 'a bucket array;
+    mutable size : int;
+  }
+
+  let size tbl = tbl.size
+
+  let _reached_max_load tbl =
+    let n = Array.length tbl.arr in
+    (n - tbl.size) < n/10 (* full at 9/10 *)
+
+  let create i =
+    let i = min Sys.max_array_length (max i 8) in
+    { arr=Array.make i Empty; size=0; }
+
+  (* initial index for a value with hash [h] *)
+  let _initial_idx tbl h =
+    h mod Array.length tbl.arr
+
+  let _succ tbl i =
+    if i = Array.length tbl.arr-1 then 0 else i+1
+
+  let _pred tbl i =
+    if i = 0 then Array.length tbl.arr - 1 else i-1
+
+  (* distance to initial bucket, at index [i] with hash [h] *)
+  let _dib tbl h i =
+    let i0 = _initial_idx tbl h in
+    if i>=i0
+      then i-i0
+      else i+ (Array.length tbl.arr - i0 - 1)
+
+  (* insert k->v in [tbl], currently at index [i] *)
+  let rec _linear_probe tbl k v h_k i =
+    match tbl.arr.(i) with
+    | Empty ->
+        (* add binding *)
+        tbl.size <- 1 + tbl.size;
+        tbl.arr.(i) <- Key (k, v, h_k)
+    | Key (k', _, h_k') when X.equal k k' ->
+        (* replace *)
+        assert (h_k = h_k');
+        tbl.arr.(i) <- Key (k, v, h_k)
+    | Key (k', v', h_k') ->
+        if _dib tbl h_k i < _dib tbl h_k' i
+        then (
+          (* replace *)
+          tbl.arr.(i) <- Key (k, v, h_k);
+          _linear_probe tbl k' v' h_k' (_succ tbl i)
+        ) else
+          (* go further *)
+          _linear_probe tbl k v h_k (_succ tbl i)
+
+  (* resize table: put a bigger array in it, then insert values
+    from the old array *)
+  let _resize tbl =
+    let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in
+    let arr' = Array.make size' Empty in
+    let old_arr = tbl.arr in
+    (* replace with new table *)
+    tbl.size <- 0;
+    tbl.arr <- arr';
+    Array.iter
+      (function
+        | Empty -> ()
+        | Key (k, v, h_k) -> _linear_probe tbl k v h_k (_initial_idx tbl h_k)
+      ) old_arr
+
+  let add tbl k v =
+    if _reached_max_load tbl
+      then _resize tbl;
+    (* insert value *)
+    let h_k = X.hash k in
+    _linear_probe tbl k v h_k (_initial_idx tbl h_k)
+
+  (* shift back elements that have a DIB > 0 until an empty bucket is
+   met, or some element doesn't need shifting *)
+  let rec _backward_shift tbl i =
+    match tbl.arr.(i) with
+    | Empty -> ()
+    | Key (_, _, h_k) when _dib tbl h_k i = 0 ->
+        ()  (* stop *)
+    | Key (k, v, h_k) as bucket ->
+        assert (_dib tbl h_k i > 0);
+        (* shift backward *)
+        tbl.arr.(_pred tbl i) <- bucket;
+        tbl.arr.(i) <- Empty;
+        _backward_shift tbl (_succ tbl i)
+
+  (* linear probing for removal of [k] *)
+  let rec _linear_probe_remove tbl k h_k i =
+    match tbl.arr.(i) with
+    | Empty -> ()
+    | Key (k', _, _) when X.equal k k' ->
+        tbl.arr.(i) <- Empty;
+        tbl.size <- tbl.size - 1;
+        _backward_shift tbl (_succ tbl i)
+    | Key (_, _, h_k') ->
+        if _dib tbl h_k' i < _dib tbl h_k i
+          then ()  (* [k] not present, would be here otherwise *)
+          else _linear_probe_remove tbl k h_k (_succ tbl i)
+
+  let remove tbl k =
+    let h_k = X.hash k in
+    _linear_probe_remove tbl k h_k (_initial_idx tbl h_k)
+
+  let rec _get_exn tbl k h_k i dib =
+    match tbl.arr.(i) with
+    | Empty -> raise Not_found
+    | Key (k', v', _) when X.equal k k' -> v'
+    | Key (_, _, h_k') ->
+        if (dib > 3 && _dib tbl h_k' i < dib)
+          then raise Not_found  (* [k] would be here otherwise *)
+          else _get_exn tbl k h_k (_succ tbl i) (dib+1)
+
+  let get_exn k tbl =
+    let h_k = X.hash k in
+    let i0 = _initial_idx tbl h_k in
+    match tbl.arr.(i0) with
+      | Empty -> raise Not_found
+      | Key (k', v, _) when X.equal k k' -> v
+      | Key _ -> _get_exn tbl k h_k (_succ tbl i0) 1
+
+  let get k tbl =
+    try Some (get_exn k tbl)
+    with Not_found -> None
+
+  let find_exn tbl k = get_exn k tbl
+
+  let find tbl k =
+    try Some (get_exn k tbl)
+    with Not_found -> None
+
+  let mem tbl k =
+    try ignore (get_exn k tbl); true
+    with Not_found -> false
+
+  let of_list l =
+    let tbl = create 16 in
+    List.iter (fun (k,v) -> add tbl k v) l;
+    tbl
+
+  let to_list tbl =
+    Array.fold_left
+      (fun acc bucket -> match bucket with
+        | Empty -> acc
+        | Key (k,v,_) -> (k,v)::acc
+      ) [] tbl.arr
+
+  let of_seq seq =
+    let tbl = create 16 in
+    seq (fun (k,v) -> add tbl k v);
+    tbl
+
+  let to_seq tbl yield =
+    Array.iter
+      (function Empty -> () | Key (k, v, _) -> yield (k,v))
+      tbl.arr
+
+  let keys tbl yield =
+    Array.iter
+      (function Empty -> () | Key (k, _, _) -> yield k)
+      tbl.arr
+
+  let values tbl yield =
+    Array.iter
+      (function Empty -> () | Key (_, v, _) -> yield v)
+      tbl.arr
+end
+

core/CCHashtbl.mli

@@ -0,0 +1,79 @@
+
+(*
+copyright (c) 2013-2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+
+(** {1 Open-Addressing Hash-table} *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : int -> 'a t
+  (** Create a new table of the given initial capacity *)
+
+  val mem : 'a t -> key -> bool
+  (** [mem tbl k] returns [true] iff [k] is mapped to some value
+      in [tbl] *)
+
+  val find : 'a t -> key -> 'a option
+
+  val find_exn : 'a t -> key -> 'a
+
+  val get : key -> 'a t -> 'a option
+  (** [get k tbl] recovers the value for [k] in [tbl], or
+      returns [None] if [k] doesn't belong *)
+
+  val get_exn : key -> 'a t -> 'a
+
+  val add : 'a t -> key -> 'a -> unit
+  (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old
+      value associated with [k]. *)
+
+  val remove : 'a t -> key -> unit
+  (** Remove binding *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+
+  val of_seq : (key * 'a) sequence -> 'a t
+  val to_seq : 'a t -> (key * 'a) sequence
+
+  val keys : _ t -> key sequence
+  val values : 'a t -> 'a sequence
+end
+
+module type HASHABLE = sig
+  type t
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module Make(X : HASHABLE) : S with type key = X.t

core/CCList.ml

@@ -179,6 +179,19 @@ let sorted_merge ?(cmp=Pervasives.compare) l1 l2 =
     = [11; 20; 101; 200]
 *)
 
+let sort_uniq (type elt) ?(cmp=Pervasives.compare) l =
+  let module S = Set.Make(struct
+    type t = elt
+    let compare = cmp
+  end) in
+  let set = fold_right S.add l S.empty in
+  S.elements set
+
+(*$T
+  sort_uniq [1;2;5;3;6;1;4;2;3] = [1;2;3;4;5;6]
+  sort_uniq [] = []
+  sort_uniq [10;10;10;10;1;10] = [1;10]
+*)
 
 let take n l =
   let rec direct i n l = match l with
@@ -513,6 +526,15 @@ module Traverse(M : MONAD) = struct
           aux f (x' :: acc) tail
     in aux f [] l
 
+  let rec map_m_par f l = match l with
+    | [] -> M.return []
+    | x::tl ->
+        let x' = f x in
+        let tl' = map_m_par f tl in
+        x' >>= fun x' ->
+        tl' >>= fun tl' ->
+        M.return (x'::tl')
+
   let sequence_m l = map_m (fun x->x) l
 
   let rec fold_m f acc l = match l with

core/CCList.mli

@@ -101,6 +101,9 @@ val filter_map : ('a -> 'b option) -> 'a t -> 'b t
 val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
 (** merges elements from both sorted list, removing duplicates *)
 
+val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list
+(** Sort the list and remove duplicate elements *)
+
 (** {2 Indices} *)
 
 module Idx : sig
@@ -233,6 +236,11 @@ module Traverse(M : MONAD) : sig
   val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t
 
   val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t
+
+  val map_m_par : ('a -> 'b M.t) -> 'a t -> 'b t M.t
+  (** Same as {!map_m} but [map_m_par f (x::l)] evaluates [f x] and
+      [f l] "in parallel" before combining their result (for instance
+      in Lwt). *)
 end
 
 (** {2 Conversions} *)

core/CCPrint.ml

@@ -24,7 +24,7 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)
 
-(** {1 GADT Description of Printers}
+(** {1 Printer Combinators}
 
 This module provides combinators to build printers for user-defined types.
 It doesn't try to do {b pretty}-printing (see for instance Pprint for this),
@@ -127,6 +127,13 @@ let fprintf oc format =
     buffer
     format
 
+let kfprintf k oc format =
+  let buffer = Buffer.create 64 in
+  Printf.kbprintf
+    (fun fmt -> Buffer.output_buffer oc buffer; k fmt)
+    buffer
+    format
+
 let printf format = fprintf stdout format
 let eprintf format = fprintf stderr format
 
@@ -134,8 +141,6 @@ let _with_file_out filename f =
   let oc = open_out filename in
   begin try
     let x = f oc in
-    flush oc;
-    close_out oc;
     x
   with e ->
     close_out_noerr oc;
@@ -143,4 +148,35 @@ let _with_file_out filename f =
   end
 
 let to_file filename format =
-  _with_file_out filename (fun oc -> fprintf oc format)
+  _with_file_out filename (fun oc -> kfprintf (fun _ -> close_out oc) oc format)
+
+(** {2 Monadic IO} *)
+
+module type MONAD_IO = sig
+  type 'a t     (** the IO monad *)
+  type output   (** Output channels *)
+
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+
+  val write : output -> string -> unit t
+end
+
+module MakeIO(M : MONAD_IO) = struct
+  let output out pp x =
+    let buf = Buffer.create 128 in
+    pp buf x;
+    M.write out (Buffer.contents buf)
+
+  let printl out pp x =
+    let buf = Buffer.create 128 in
+    pp buf x;
+    Buffer.add_char buf '\n';
+    M.write out (Buffer.contents buf)
+
+  let fprintf out format =
+    let buf = Buffer.create 128 in
+    Printf.kbprintf
+      (fun buf -> M.write out (Buffer.contents buf))
+      buf
+      format
+end

core/CCPrint.mli

@@ -24,11 +24,34 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)
 
-(** {1 GADT Description of Printers}
+(** {1 Printer Combinators}
 
 This module provides combinators to build printers for user-defined types.
 It doesn't try to do {b pretty}-printing (see for instance Pprint for this),
 but a simple way to print complicated values without writing a lot of code.
+
+Those combinators work with "%a". For instance to print a
+[(int * bool) list list] and a [float array], one can write:
+{[
+  CCPrint.(printf "int: %d list: %a, array: %a\n"
+    42
+    (list (list (pair int bool))) [[1, true; 2, false]; [4, true]]
+    (array float) [| 1. ; 2. ; 3e18 |] ;;
+]}
+
+Remember that "%a" in this context requires two arguments:
+  - a value of type ['a t] (buffer printer)
+  - a value of type ['a] (value to print)
+
+To define new printers, one can either use existing ones (e.g. [list int]),
+or use {!Printf.bprintf}. For instance a printer for colored points in 2D:
+
+{[ type point = {x:int; y:int; colors: string list};;
+
+let pp_point buf p =
+  Printf.bprintf buf "{x=%d, y=%d, colors=%a}"
+    p.x p.y CCPrint.(list string) p.colors;;
+]}
 *)
 
 type 'a sequence = ('a -> unit) -> unit
@@ -76,3 +99,35 @@ val to_file : string -> ('a, Buffer.t, unit, unit) format4 -> 'a
 
 val printf : ('a, Buffer.t, unit, unit) format4 -> 'a
 val eprintf : ('a, Buffer.t, unit, unit) format4 -> 'a
+
+(** {2 Monadic IO} *)
+
+module type MONAD_IO = sig
+  type 'a t     (** the IO monad *)
+  type output   (** Output channels *)
+
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+
+  val write : output -> string -> unit t
+end
+
+module MakeIO(M : MONAD_IO) : sig
+  val output : M.output -> 'a t -> 'a -> unit M.t
+  (** Output a single value *)
+
+  val printl : M.output -> 'a t -> 'a -> unit M.t
+  (** Output a value and add a newline "\n" after. *)
+
+  val fprintf : M.output -> ('a, Buffer.t, unit, unit M.t) format4 -> 'a
+  (** Fprintf on a monadic output *)
+end
+(** Example:
+{[ module PrintLwt = CCPrint.MakeIO(struct
+    include Lwt
+    type output = Lwt_io.output_channel
+    let write = Lwt_io.write
+  end);;
+
+  PrintLwt.printl Lwt_io.stdout (CCList.pp CCInt.pp) [1;2;3;4];;
+  - : unit Lwt.t
+]} *)

core/CCString.ml

@@ -41,10 +41,9 @@ module type S = sig
   (** {2 Conversions} *)
 
   val to_gen : t -> char gen
-
   val to_seq : t -> char sequence
-
   val to_klist : t -> char klist
+  val to_list : t -> char list
 
   val pp : Buffer.t -> t -> unit
 end
@@ -59,6 +58,10 @@ let hash s = Hashtbl.hash s
 
 let length = String.length
 
+let rec _to_list s acc i len =
+  if len=0 then List.rev acc
+  else _to_list s (s.[i]::acc) (i+1) (len-1)
+
 let _is_sub ~sub i s j ~len =
   let rec check k =
     if k = len
@@ -220,6 +223,26 @@ let of_klist l =
 
 let to_klist s = _to_klist s 0 (String.length s)
 
+let to_list s = _to_list s [] 0 (String.length s)
+
+let of_list l =
+  let s = String.make (List.length l) ' ' in
+  List.iteri (fun i c -> s.[i] <- c) l;
+  s
+
+(*$T
+  of_list ['a'; 'b'; 'c'] = "abc"
+  of_list [] = ""
+*)
+
+let of_array a =
+  let s = String.make (Array.length a) ' ' in
+  Array.iteri (fun i c -> s.[i] <- c) a;
+  s
+
+let to_array s =
+  Array.init (String.length s) (fun i -> s.[i])
+
 let pp buf s =
   Buffer.add_char buf '"';
   Buffer.add_string buf s;
@@ -252,6 +275,7 @@ module Sub = struct
   let to_seq (s,i,len) k =
     for i=i to i+len-1 do k s.[i] done
   let to_klist (s,i,len) = _to_klist s i len
+  let to_list (s,i,len) = _to_list s [] i len
 
   let pp buf (s,i,len) =
     Buffer.add_char buf '"';

core/CCString.mli

@@ -45,10 +45,9 @@ module type S = sig
   (** {2 Conversions} *)
 
   val to_gen : t -> char gen
-
   val to_seq : t -> char sequence
-
   val to_klist : t -> char klist
+  val to_list : t -> char list
 
   val pp : Buffer.t -> t -> unit
 end
@@ -64,10 +63,12 @@ val compare : t -> t -> int
 val hash : t -> int
 
 val of_gen : char gen -> t
-
 val of_seq : char sequence -> t
-
 val of_klist : char klist -> t
+val of_list : char list -> t
+val of_array : char array -> t
+
+val to_array : t -> char array
 
 val find : ?start:int -> sub:t -> t -> int
 (** Find [sub] in the string, returns its first index or -1.

misc/bTree.ml

@@ -0,0 +1,382 @@
+
+(*
+copyright (c) 2013, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 B-Trees} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+
+(** {2 signature} *)
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : unit -> 'a t
+  (** Empty map *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val add : key -> 'a -> 'a t -> unit
+  (** Add a binding to the tree. Erases the old binding, if any *)
+
+  val remove : key -> 'a t -> unit
+  (** Remove the given key, or does nothing if the key isn't present *)
+
+  val get : key -> 'a t -> 'a option
+  (** Key lookup *)
+
+  val get_exn : key -> 'a t -> 'a
+  (** Unsafe version of {!get}.
+      @raise Not_found if the key is not present *)
+
+  val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
+  (** Fold on bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+  val to_tree : 'a t -> (key * 'a) list ktree
+end
+
+(** {2 Functor} *)
+
+module type ORDERED = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module Make(X : ORDERED) = struct
+  type key = X.t
+
+  let _len_node = 1 lsl 6
+  let _min_len = _len_node / 2
+
+  (* B-tree *)
+  type 'a tree =
+    | E
+    | N of 'a node
+    | L of 'a node
+
+  (* an internal node, with children separated by keys/value pairs.
+    the [i]-th key of [n.keys] separates the subtrees [n.children.(i)] and
+    [n.children.(i+1)] *)
+  and 'a node = {
+    keys : key array;
+    values : 'a array;
+    children : 'a tree array; (* with one more slot *)
+    mutable size : int;  (* number of bindings in the [key] *)
+  }
+
+  type 'a t = {
+    mutable root : 'a tree;
+    mutable cardinal : int;
+  }
+
+  let is_empty = function
+    | E -> true
+    | N _
+    | L _ -> false
+
+  let create () = {
+    root=E;
+    cardinal=0;
+  }
+
+  (* build a new leaf with the given binding *)
+  let _make_singleton k v = {
+    keys = Array.make _len_node k;
+    values = Array.make _len_node v;
+    children = Array.make (_len_node+1) E;
+    size = 1;
+  }
+
+  (* slice of [l] starting at indices [i], of length [len]. Only
+    copies inner children (between two keys in the range). *)
+  let _make_slice l i len =
+    assert (len>0);
+    assert (i+len<=l.size);
+    let k = l.keys.(i) and v = l.values.(i)  in
+    let l' = {
+      keys = Array.make _len_node k;
+      values = Array.make _len_node v;
+      children = Array.make (_len_node+1) E;
+      size = len;
+    } in
+    Array.blit l.keys i l'.keys 0 len;
+    Array.blit l.values i l'.values 0 len;
+    Array.blit l.children (i+1) l'.children 1 (len-1);
+    l'
+
+  let _full_node n = n.size = _len_node
+  let _empty_node n = n.size = 0
+
+  let size t = t.cardinal
+
+  let rec _fold f acc t = match t with
+    | E -> ()
+    | L n ->
+        for i=0 to n.size-1 do
+          assert (n.children.(i) = E);
+          acc := f !acc n.keys.(i) n.values.(i)
+        done
+    | N n ->
+        for i=0 to n.size-1 do
+          _fold f acc n.children.(i);
+          acc := f !acc n.keys.(i) n.values.(i);
+        done;
+        _fold f acc n.children.(n.size)
+
+  let fold f acc t =
+    let acc = ref acc in
+    _fold f acc t.root;
+    !acc
+
+  type lookup_result =
+    | At of int
+    | After of int
+
+  (* lookup in a node. *)
+  let rec _lookup_rec l k i =
+    if i = l.size then After (i-1)
+    else match X.compare k l.keys.(i) with
+      | 0 -> At i
+      | n when n<0 -> After (i-1)
+      | _ -> _lookup_rec l k (i+1)
+
+  let _lookup l k =
+    if l.size = 0 then After ~-1
+    else _lookup_rec l k 0
+
+  (* recursive lookup in a tree *)
+  let rec _get_exn k t = match t with
+    | E -> raise Not_found
+    | L l ->
+        begin match _lookup l k with
+        | At i -> l.values.(i)
+        | After _ -> raise Not_found
+        end
+    | N n ->
+        assert (n.size > 0);
+        match _lookup n k with
+        | At i -> n.values.(i)
+        | After i -> _get_exn k n.children.(i+1)
+
+  let get_exn k t = _get_exn k t.root
+
+  let get k t =
+    try Some (_get_exn k t.root)
+    with Not_found -> None
+
+  (* sorted insertion into a leaf that has room and doesn't contain the key *)
+  let _insert_sorted l k v i =
+    assert (not (_full_node l));
+    (* make room by shifting to the right *)
+    let len = l.size - i in
+    assert (i+len<=l.size);
+    assert (len>=0);
+    Array.blit l.keys i l.keys (i+1) len;
+    Array.blit l.values i l.values (i+1) len;
+    l.keys.(i) <- k;
+    l.values.(i) <- v;
+    l.size <- l.size + 1;
+
+  (* what happens when we insert a value *)
+  type 'a add_result =
+    | NewTree of 'a tree
+    | Add
+    | Replace
+    | Split of 'a tree * key * 'a * 'a tree
+
+  let _add_leaf k v t l =
+    match _lookup l k with
+    | At i ->
+        l.values.(i) <- v;
+        Replace
+    | After i ->
+        if _full_node l
+        then (
+          (* split. [k'] and [v']: separator for split *)
+          let j = _len_node/2 in
+          let left = _make_slice l 0 j in
+          let right = _make_slice l (j+1) (_len_node-j-1) in
+          (* insert in proper sub-leaf *)
+          (if i+1<j
+            then _insert_sorted left k v (i+1)
+            else _insert_sorted right k v (i-j)
+          );
+          let k' = l.keys.(j) in
+          let v' = l.values.(j) in
+          Split (L left, k', v', L right)
+        ) else (
+          (* just insert at sorted position *)
+          _insert_sorted l k v (i+1);
+          Add
+        )
+
+  let _insert_node n i k v sub1 sub2 =
+    assert (not(_full_node n));
+    let len = n.size - i in
+    assert (len>=0);
+    Array.blit n.keys i n.keys (i+1) len;
+    Array.blit n.values i n.values (i+1) len;
+    Array.blit n.children (i+1) n.children (i+2) len;
+    n.keys.(i) <- k;
+    n.values.(i) <- v;
+    (* erase subtree with sub1,sub2 *)
+    n.children.(i) <- sub1;
+    n.children.(i+1) <- sub2;
+    n.size <- n.size + 1;
+    ()
+
+  (* return a boolean indicating whether the key was already
+    present, and a new tree. *)
+  let rec _add k v t = match t with
+    | E -> NewTree (L (_make_singleton k v))
+    | L l -> _add_leaf k v t l
+    | N n ->
+        match _lookup n k with
+        | At i ->
+            n.values.(i) <- v;
+            Replace
+        | After i ->
+          assert (X.compare n.keys.(i) k < 0);
+          let sub = n.children.(i+1) in
+          match _add k v sub with
+          | NewTree t' ->
+              n.children.(i+1) <- t';
+              Add
+          | Add -> Add
+          | Replace -> Replace
+          | Split (sub1, k', v', sub2) ->
+              assert (X.compare n.keys.(i) k' < 0);
+              if _full_node n
+              then (
+                (* split this node too! *)
+                let j = _len_node/2 in
+                let left = _make_slice n 0 j in
+                let right = _make_slice n (j+1) (_len_node-j-1) in
+                left.children.(0) <- n.children.(0);
+                right.children.(_len_node-j) <- n.children.(_len_node);
+                (* insert k' and subtrees in the correct tree *)
+                (if i<j
+                  then _insert_node left (i+1) k' v' sub1 sub2
+                  else _insert_node right (i+1-j) k' v' sub1 sub2
+                );
+                (* return the split tree *)
+                let k'' = n.keys.(j) in
+                let v'' = n.values.(j) in
+                Split (N left, k'', v'', N right)
+              ) else (
+                (* insertion of [k] at position [i+1] *)
+                _insert_node n (i+1) k' v' sub1 sub2;
+                Add
+              )
+
+  let add k v t =
+    match _add k v t.root with
+      | NewTree t' ->
+          t.cardinal <- t.cardinal + 1;
+          t.root <- t'
+      | Replace -> ()
+      | Add -> t.cardinal <- t.cardinal + 1
+      | Split (sub1, k, v, sub2) ->
+          (* make a new root with one child *)
+          let n = _make_singleton k v in
+          n.children.(0) <- sub1;
+          n.children.(1) <- sub2;
+          t.cardinal <- t.cardinal + 1;
+          t.root <- N n
+
+  let of_list l =
+    let t = create() in
+    List.iter (fun (k, v) -> add k v t) l;
+    t
+
+  let to_list t =
+    List.rev (fold (fun acc k v -> (k,v)::acc) [] t)
+
+  let rec _to_tree t () = match t with
+    | E -> `Nil
+    | L n
+    | N n ->
+        let l = ref [] and children = ref [] in
+        for i=0 to n.size-1 do
+          l := (n.keys.(i),n.values.(i)) :: !l;
+          children := n.children.(i) :: !children
+        done;
+        children := n.children.(n.size) :: !children;
+        children := List.filter (function E -> false | _ -> true) !children;
+        `Node (List.rev !l, List.rev_map _to_tree !children)
+
+  let to_tree t = _to_tree t.root
+
+  (*$T
+    let module T = Make(CCInt) in \
+      let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \
+      T.get 1 t = Some "1"
+    let module T = Make(CCInt) in \
+      let t = T.of_list (CCList.(1--1000) |> List.map (fun x->x, string_of_int x)) in \
+      T.get 3 t = Some "3"
+    let module T = Make(CCInt) in \
+      let t = T.of_list (CCList.(1--100) |> List.map (fun x->x, string_of_int x)) in \
+      T.get 400 t = None
+  *)
+
+  (* remove the key if present.  TODO
+  let rec _remove k t = match t with
+    | E -> false, E
+    | N n ->
+        assert (n.size > 0);
+        if X.compare k (_min_key n) < 0
+        then (
+          let removed, left' = _remove k n.left in
+          n.left <- left';
+          n.depth <- 1+max (_depth n.left) (_depth n.right);
+          removed, _balance t
+        ) else if X.compare k (_max_key n) > 0
+        then (
+          let removed, right' = _remove k n.right in
+          n.right <- right';
+          n.depth <- 1+max (_depth n.left) (_depth n.right);
+          removed, _balance t
+        )
+        else try
+          let i = _lookup n k 0 in
+          if n.size = 1  (* TODO: actually minimal threshold should be higher *)
+          then true, E
+          else (
+            let len = n.size - i in
+            Array.blit n.keys (i+1) n.keys i len;
+            Array.blit n.values (i+1) n.values i len;
+            true, t
+          )
+        with Not_found ->
+          false, t  (* not to be removed *)
+  *)
+
+  let remove k t = assert false (* TODO *)
+end

misc/bTree.mli

@@ -0,0 +1,90 @@
+
+(*
+copyright (c) 2013, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 B-Trees}
+
+Shallow, cache-friendly associative data structure.
+See {{: https://en.wikipedia.org/wiki/B-tree} wikipedia}.
+
+Not thread-safe.  *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+
+(** {2 signature} *)
+
+module type S = sig
+  type key
+  type 'a t
+
+  val create : unit -> 'a t
+  (** Empty map *)
+
+  val size : _ t -> int
+  (** Number of bindings *)
+
+  val add : key -> 'a -> 'a t -> unit
+  (** Add a binding to the tree. Erases the old binding, if any *)
+
+  val remove : key -> 'a t -> unit
+  (** Remove the given key, or does nothing if the key isn't present *)
+
+  val get : key -> 'a t -> 'a option
+  (** Key lookup *)
+
+  val get_exn : key -> 'a t -> 'a
+  (** Unsafe version of {!get}.
+      @raise Not_found if the key is not present *)
+
+  val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
+  (** Fold on bindings *)
+
+  val of_list : (key * 'a) list -> 'a t
+  val to_list : 'a t -> (key * 'a) list
+  val to_tree : 'a t -> (key * 'a) list ktree
+end
+
+(** {2 Functor that builds trees for comparable keys} *)
+
+module type ORDERED = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module Make(X : ORDERED) : S with type key = X.t
+
+(* note: to print a B-tree in dot:
+{[
+let t = some_btree in
+let t' = CCKTree.map
+  (fun t ->
+    [`Shape "square";
+     `Label (CCPrint.to_string (CCList.pp (CCPair.pp CCInt.pp CCString.pp)) t)]
+  ) (T.to_tree t);;
+CCPrint.to_file "/tmp/some_file.dot" "%a\n" (CCKTree.Dot.pp_single "btree") t';
+]}
+*)
+

misc/printBox.ml

@@ -277,6 +277,13 @@ let text s =
   _lines s 0 (fun x -> acc := x :: !acc);
   Box._make (Box.Text (List.rev !acc))
 
+let sprintf format =
+  let buffer = Buffer.create 64 in
+  Printf.kbprintf
+    (fun fmt -> text (Buffer.contents buffer))
+    buffer
+    format
+
 let lines l =
   assert (List.for_all (fun s -> _find s '\n' 0 = None) l);
   Box._make (Box.Text l)
@@ -359,25 +366,6 @@ let _write_hline ~out pos n =
     Output.put_char out (_move_x pos i) '-'
   done
 
-type simple_box =
-  [ `Empty
-  | `Pad of simple_box
-  | `Text of string
-  | `Vlist of simple_box list
-  | `Hlist of simple_box list
-  | `Table of simple_box array array
-  | `Tree of simple_box * simple_box list
-  ]
-
-let rec of_simple = function
-  | `Empty -> empty
-  | `Pad b -> pad (of_simple b)
-  | `Text t -> pad (text t)
-  | `Vlist l -> vlist (List.map of_simple l)
-  | `Hlist l -> hlist (List.map of_simple l)
-  | `Table a -> grid (Box._map_matrix of_simple a)
-  | `Tree (b,l) -> tree (of_simple b) (List.map of_simple l)
-
 (* render given box on the output, starting with upper left corner
     at the given position. [expected_size] is the size of the
     available surrounding space. [offset] is the offset of the box
@@ -477,3 +465,47 @@ let output ?(indent=0) oc b =
   render out b;
   Output.buf_output ~indent oc buf;
   flush oc
+
+(** {2 Simple Structural Interface} *)
+
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+
+module Simple = struct
+  type t =
+    [ `Empty
+    | `Pad of t
+    | `Text of string
+    | `Vlist of t list
+    | `Hlist of t list
+    | `Table of t array array
+    | `Tree of t * t list
+    ]
+
+  let rec to_box = function
+    | `Empty -> empty
+    | `Pad b -> pad (to_box b)
+    | `Text t -> text t
+    | `Vlist l -> vlist (List.map to_box l)
+    | `Hlist l -> hlist (List.map to_box l)
+    | `Table a -> grid (Box._map_matrix to_box a)
+    | `Tree (b,l) -> tree (to_box b) (List.map to_box l)
+
+  let rec of_ktree t = match t () with
+    | `Nil -> `Empty
+    | `Node (x, l) -> `Tree (x, List.map of_ktree l)
+
+  let rec map_ktree f t = match t () with
+    | `Nil -> `Empty
+    | `Node (x, l) -> `Tree (f x, List.map (map_ktree f) l)
+
+  let sprintf format =
+    let buffer = Buffer.create 64 in
+    Printf.kbprintf
+      (fun fmt -> `Text (Buffer.contents buffer))
+      buffer
+      format
+
+  let render out x = render out (to_box x)
+  let to_string x = to_string (to_box x)
+  let output ?indent out x = output ?indent out (to_box x)
+end

misc/printBox.mli

@@ -120,6 +120,9 @@ val line : string -> Box.t
 val text : string -> Box.t
 (** Any text, possibly with several lines *)
 
+val sprintf : ('a, Buffer.t, unit, Box.t) format4 -> 'a
+(** Formatting for {!text} *)
+
 val lines : string list -> Box.t
 (** Shortcut for {!text}, with a list of lines *)
 
@@ -182,18 +185,6 @@ val mk_tree : ?indent:int -> ('a -> Box.t * 'a list) -> 'a -> Box.t
 (** Definition of a tree with a local function that maps nodes to
     their content and children *)
 
-type simple_box =
-  [ `Empty
-  | `Pad of simple_box
-  | `Text of string
-  | `Vlist of simple_box list
-  | `Hlist of simple_box list
-  | `Table of simple_box array array
-  | `Tree of simple_box * simple_box list
-  ]
-
-val of_simple : simple_box -> Box.t
-
 (** {2 Rendering} *)
 
 val render : Output.t -> Box.t -> unit
@@ -201,3 +192,36 @@ val render : Output.t -> Box.t -> unit
 val to_string : Box.t -> string
 
 val output : ?indent:int -> out_channel -> Box.t -> unit
+
+(** {2 Simple Structural Interface} *)
+
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+
+module Simple : sig
+  type t =
+    [ `Empty
+    | `Pad of t
+    | `Text of string
+    | `Vlist of t list
+    | `Hlist of t list
+    | `Table of t array array
+    | `Tree of t * t list
+    ]
+
+  val of_ktree : t ktree -> t
+  (** Helper to convert trees *)
+
+  val map_ktree : ('a -> t) -> 'a ktree -> t
+  (** Helper to map trees into recursive boxes *)
+
+  val to_box : t -> Box.t
+
+  val sprintf : ('a, Buffer.t, unit, t) format4 -> 'a
+  (** Formatting for [`Text] *)
+
+  val render : Output.t -> t -> unit
+
+  val to_string : t -> string
+
+  val output : ?indent:int -> out_channel -> t -> unit
+end

tests/benchs.ml

@@ -31,6 +31,12 @@ module IMap = Map.Make(struct
   let compare i j = i - j
 end)
 
+module ICCHashtbl = CCHashtbl.Make(struct
+  type t = int
+  let equal i j = i = j
+  let hash i = i
+end)
+
 let phashtbl_add n =
   let h = PHashtbl.create 50 in
   for i = n downto 0 do
@@ -87,6 +93,13 @@ let imap_add n =
   done;
   !h
 
+let icchashtbl_add n =
+  let h = ICCHashtbl.create 50 in
+  for i = n downto 0 do
+    ICCHashtbl.add h i i;
+  done;
+  h
+
 let bench_maps1 () =
   Format.printf "----------------------------------------@.";
   let res = Bench.bench_n
@@ -98,6 +111,7 @@ let bench_maps1 () =
      "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n));
      "skiplist_add", (fun n -> ignore (skiplist_add n));
      "imap_add", (fun n -> ignore (imap_add n));
+     "cchashtbl_add", (fun n -> ignore (icchashtbl_add n))
     ]
   in
   Bench.summarize 1. res
@@ -182,6 +196,16 @@ let imap_replace n =
   done;
   !h
 
+let icchashtbl_replace n =
+  let h = ICCHashtbl.create 50 in
+  for i = 0 to n do
+    ICCHashtbl.add h i i;
+  done;
+  for i = n downto 0 do
+    ICCHashtbl.add h i i;
+  done;
+  h
+
 let bench_maps2 () =
   Format.printf "----------------------------------------@.";
   let res = Bench.bench_n
@@ -193,6 +217,7 @@ let bench_maps2 () =
      "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n));
      "skiplist_replace", (fun n -> ignore (skiplist_replace n));
      "imap_replace", (fun n -> ignore (imap_replace n));
+     "cchashtbl_replace", (fun n -> ignore (icchashtbl_replace n));
     ]
   in
   Bench.summarize 1. res
@@ -253,6 +278,12 @@ let imap_find m =
       ignore (IMap.find i m);
     done
 
+let icchashtbl_find m =
+  fun n ->
+    for i = 0 to n-1 do
+      ignore (ICCHashtbl.find_exn m i);
+    done
+
 let bench_maps3 () =
   List.iter
     (fun len ->
@@ -265,6 +296,7 @@ let bench_maps3 () =
       let l = skiplist_add len in
       let a = Array.init len (fun i -> string_of_int i) in
       let m = imap_add len in
+      let h'''''' = icchashtbl_add len in
       Format.printf "----------------------------------------@.";
       Format.printf "try on size %d@.@.@." len;
       Bench.bench [
@@ -277,6 +309,7 @@ let bench_maps3 () =
         "skiplist_find", (fun () -> skiplist_find l len);
         "array_find", (fun () -> array_find a len);
         "imap_find", (fun () -> imap_find m len);
+        "cchashtbl_find", (fun () -> icchashtbl_find h'''''' len);
       ])
     [10;20;100;1000;10000]
 

tests/helpers.ml

@@ -7,7 +7,6 @@ let print_int_list l =
   Buffer.contents b
 
 let print_int_int_list l =
-  let printer fmt (i,j) = Format.fprintf fmt "%d, %d" i j in
   let b = Buffer.create 20 in
   CCList.pp (CCPair.pp CCInt.pp CCInt.pp) b l;
   Buffer.contents b

tests/test_PersistentHashtbl.ml

@@ -154,7 +154,7 @@ let check_old_new =
   let prop l =
     let l1, l2 = List.partition (fun (x,_) -> x mod 2 = 0) l in
     let h1 = H.of_list l1 in
-    let h2 = H.of_list ~init:h1 l2 in
+    let h2 = H.add_list h1 l2 in
     List.for_all
       (fun (k,v) -> H.find h2 k = v)
       l