merge from dev

.merlin

@@ -9,7 +9,7 @@ B _build/string
 B _build/tests
 B _build/examples
 PKG oUnit
-PKG bench
+PKG benchmark
 PKG threads
 PKG threads.posix
 PKG lwt

Makefile

@@ -62,12 +62,14 @@ QTESTABLE=$(filter-out $(DONTTEST), \
 qtest-clean:
 	@rm -rf qtest/
 
-qtest: qtest-clean build
+qtest-build: qtest-clean build
 	@mkdir -p qtest
 	@qtest extract -o qtest/qtest_all.ml $(QTESTABLE) 2> /dev/null
 	@ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib \
 		-I core -I misc -I string \
 		qtest/qtest_all.native
+
+qtest: qtest-build
 	@echo 
 	./qtest_all.native
 
@@ -82,7 +84,11 @@ push-stable: all
 clean-generated:
 	rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f
 
-test-all: test qtest
+run-test: build qtest-build
+	./qtest_all.native
+	./run_tests.native
+
+test-all: run-test qtest
 
 tags:
 	otags *.ml *.mli

README.md

@@ -49,18 +49,28 @@ structures comprise (some modules in `misc/`, some other in `core/`):
 
 ### Core Structures
 
-- `CCLeftistheap`, a polymorphic heap structure.
+- `CCHeap`, a purely functional heap structure.
-- `CCFQueue`, a purely functional queue structure
+- `CCFQueue`, a purely functional double-ended queue structure
 - `CCBV`, mutable bitvectors
 - `CCPersistentHashtbl`, a semi-persistent hashtable (similar to [persistent arrays](https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html))
-- `CCVector`, a growable array (pure OCaml, no C)
+- `CCVector`, a growable array (pure OCaml, no C) with mutability annotations
 - `CCGen` and `CCSequence`, generic iterators structures (with structural types so they can be defined in several places). Now also in their own repository and opam packages (`gen` and `sequence`).
-- `CCKlist`, another iterator structure
+- `CCKlist`, a persistent iterator structure (akin to a lazy list)
-- `CCList`, functions and lists including tail-recursive implementations of `map` and `append`
+- `CCList`, functions and lists including tail-recursive implementations of `map` and `append` and many other utilities
-- `CCArray`, utilities on arrays
+- `CCArray`, utilities on arrays and slices
-- `CCInt`, `CCPair`, `CCOpt`, `CCFun`, `CCBool`, utilities on basic types
+- `CCLinq`, high-level query language over collections
-- `CCPrint`, printing combinators
+- `CCMultimap` and `CCMultiset`, functors defining persistent structures
-- `CCHash`, hashing combinators
+- small modules (basic types, utilities):
+  - `CCInt`
+  - `CCPair` (cartesian products)
+  - `CCOpt` (options)
+  - `CCFun` (function combinators)
+  - `CCBool`
+  - `CCOrd` (combinators for total orderings)
+  - `CCRandom` (combinators for random generators)
+  - `CCPrint` (printing combinators)
+  - `CCHash` (hashing combinators)
+  - `CCError` (monadic error handling)
 
 ### Misc
 

_oasis

@@ -40,8 +40,9 @@ Library "containers"
   Path:             core
   Modules:          CCVector, CCDeque, CCGen, CCSequence, CCFQueue, CCMultiMap,
                     CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError,
-                    CCLeftistheap, CCList, CCOpt, CCPair, CCFun, CCHash,
+                    CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
-                    CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCLinq
+                    CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd,
+                    CCRandom, CCLinq
   FindlibName:      containers
 
 Library "containers_string"
@@ -145,6 +146,14 @@ Executable bench_batch
   MainIs: bench_batch.ml
   BuildDepends: containers,benchmark
 
+Executable bench_hash
+  Path: tests/
+  Install: false
+  CompiledObject: native
+  Build$: flag(bench) && flag(misc)
+  MainIs: bench_hash.ml
+  BuildDepends: containers,containers.misc
+
 Executable test_levenshtein
   Path: tests/
   Install: false
@@ -170,7 +179,7 @@ Executable test_threads
   BuildDepends: containers,threads,oUnit,containers.lwt
 
 Test all
-  Command: $run_tests
+  Command: make test-all
   TestTools: run_tests
   Run$: flag(tests)
 

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 38b5b440371d718e4e43cec96202bee7)
+# DO NOT EDIT (digest: 3e4b3ffbcf17509bedefd6d577653253)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -85,8 +85,6 @@
 "tests/benchs.native": use_containers_misc
 "tests/benchs.native": use_containers_string
 <tests/*.ml{,i}>: package(bench)
-<tests/*.ml{,i}>: package(unix)
-<tests/*.ml{,i}>: use_containers_misc
 <tests/*.ml{,i}>: use_containers_string
 # Executable bench_conv
 "tests/bench_conv.native": package(benchmark)
@@ -95,6 +93,12 @@
 "tests/bench_batch.native": package(benchmark)
 "tests/bench_batch.native": use_containers
 <tests/*.ml{,i}>: package(benchmark)
+# Executable bench_hash
+"tests/bench_hash.native": package(unix)
+"tests/bench_hash.native": use_containers
+"tests/bench_hash.native": use_containers_misc
+<tests/*.ml{,i}>: package(unix)
+<tests/*.ml{,i}>: use_containers_misc
 # Executable test_levenshtein
 "tests/test_levenshtein.native": package(qcheck)
 "tests/test_levenshtein.native": use_containers

containers.odocl

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 1d7d103e81e0ed014552a439c48db02a)
+# DO NOT EDIT (digest: 71885759eab42ad3dd73d2ce208fd28b)
 core/CCVector
 core/CCDeque
 core/CCGen
@@ -11,7 +11,7 @@ core/CCBV
 core/CCPrint
 core/CCPersistentHashtbl
 core/CCError
-core/CCLeftistheap
+core/CCHeap
 core/CCList
 core/CCOpt
 core/CCPair
@@ -23,6 +23,7 @@ core/CCBool
 core/CCArray
 core/CCBatch
 core/CCOrd
+core/CCRandom
 core/CCLinq
 string/KMP
 string/CCString

core/CCArray.ml

@@ -30,6 +30,7 @@ type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a gen = unit -> 'a option
 type 'a equal = 'a -> 'a -> bool
 type 'a ord = 'a -> 'a -> int
+type 'a random_gen = Random.State.t -> 'a
 
 module type S = sig
   type 'a t
@@ -81,6 +82,10 @@ module type S = sig
   val shuffle_with : Random.State.t -> 'a t -> unit
   (** Like shuffle but using a specialized random state *)
 
+  val random_choose : 'a t -> 'a random_gen
+  (** Choose an element randomly.
+      @raise Not_found if the array/slice is empty *)
+
   val to_seq : 'a t -> 'a sequence
   val to_gen : 'a t -> 'a gen
   val to_klist : 'a t -> 'a klist
@@ -161,6 +166,10 @@ let _shuffle _rand_int a i j =
     a.(l) <- tmp;
   done
 
+let _choose a i j st =
+  if i>=j then raise Not_found;
+  a.(i+Random.int (j-i))
+
 let _pp ~sep pp_item buf a i j =
   for k = i to j - 1 do
     if k > i then Buffer.add_string buf sep;
@@ -321,6 +330,19 @@ let shuffle a = _shuffle Random.int a 0 (Array.length a)
 
 let shuffle_with st a = _shuffle (Random.State.int st) a 0 (Array.length a)
 
+let random_choose a st = _choose a 0 (Array.length a) st
+
+let random_len n g st =
+  Array.init n (fun _ -> g st)
+
+let random g st =
+  let n = Random.State.int st 1_000 in
+  random_len n g st
+
+let random_non_empty g st =
+  let n = 1 + Random.State.int st 1_000 in
+  random_len n g st
+
 let pp ?(sep=", ") pp_item buf a = _pp ~sep pp_item buf a 0 (Array.length a)
 
 let pp_i ?(sep=", ") pp_item buf a = _pp_i ~sep pp_item buf a 0 (Array.length a)
@@ -412,6 +434,8 @@ module Sub = struct
   let shuffle_with st a =
     _shuffle (Random.State.int st) a.arr a.i a.j
 
+  let random_choose a st = _choose a.arr a.i a.j st
+
   let pp ?(sep=", ") pp_item buf a = _pp ~sep pp_item buf a.arr a.i a.j
 
   let pp_i ?(sep=", ") pp_item buf a = _pp_i ~sep pp_item buf a.arr a.i a.j

core/CCArray.mli

@@ -30,6 +30,7 @@ type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a gen = unit -> 'a option
 type 'a equal = 'a -> 'a -> bool
 type 'a ord = 'a -> 'a -> int
+type 'a random_gen = Random.State.t -> 'a
 
 (** {2 Abstract Signature} *)
 
@@ -83,6 +84,10 @@ module type S = sig
   val shuffle_with : Random.State.t -> 'a t -> unit
   (** Like shuffle but using a specialized random state *)
 
+  val random_choose : 'a t -> 'a random_gen
+  (** Choose an element randomly.
+      @raise Not_found if the array/slice is empty *)
+
   val to_seq : 'a t -> 'a sequence
   val to_gen : 'a t -> 'a gen
   val to_klist : 'a t -> 'a klist
@@ -129,6 +134,10 @@ val except_idx : 'a t -> int -> 'a list
 val (--) : int -> int -> int t
 (** Range array *)
 
+val random : 'a random_gen -> 'a t random_gen
+val random_non_empty : 'a random_gen -> 'a t random_gen
+val random_len : int -> 'a random_gen -> 'a t random_gen
+
 (** {2 Slices}
 A slice is a part of an array, that requires no copying and shares
 its storage with the original array.

core/CCBV.ml

@@ -57,8 +57,21 @@ let create ~size default =
       { a = arr }
     end
 
+(*$T
+  create ~size:17 true |> cardinal = 17
+  create ~size:32 true |> cardinal= 32
+  create ~size:132 true |> cardinal = 132
+  create ~size:200 false |> cardinal = 0
+  create ~size:29 true |> to_sorted_list = CCList.range 0 28
+*)
+
 let copy bv = { a=Array.copy bv.a; }
 
+(*$Q
+  (Q.list Q.small_int) (fun l -> \
+    let bv = of_list l in to_list bv = to_list (copy bv))
+*)
+
 let length bv = Array.length bv.a
 
 let resize bv len =
@@ -109,6 +122,11 @@ let set bv i =
   let i = i - n * __width in
   bv.a.(n) <- bv.a.(n) lor (1 lsl i)
 
+(*$T
+  let bv = create ~size:3 false in set bv 0; get bv 0
+  let bv = create ~size:3 false in set bv 1; not (get bv 0)
+*)
+
 let reset bv i =
   let n = i / __width in
   if n >= Array.length bv.a
@@ -116,6 +134,10 @@ let reset bv i =
   let i = i - n * __width in
   bv.a.(n) <- bv.a.(n) land (lnot (1 lsl i))
 
+(*$T
+  let bv = create ~size:3 false in set bv 0; reset bv 0; not (get bv 0)
+*)
+
 let flip bv i =
   let n = i / __width in
   if n >= Array.length bv.a
@@ -126,6 +148,10 @@ let flip bv i =
 let clear bv =
   Array.iteri (fun i _ -> bv.a.(i) <- 0) bv.a
 
+(*$T
+let bv = create ~size:37 true in cardinal bv = 37 && (clear bv; cardinal bv= 0)
+*)
+
 let iter bv f =
   let len = Array.length bv.a in
   for n = 0 to len - 1 do
@@ -145,17 +171,30 @@ let iter_true bv f =
     done
   done
 
+(*$T
+  of_list [1;5;7] |> iter_true |> CCSequence.to_list |> List.sort CCOrd.compare = [1;5;7]
+*)
+
 let to_list bv =
   let l = ref [] in
   iter_true bv (fun i -> l := i :: !l);
   !l
 
+let to_sorted_list bv =
+  List.rev (to_list bv)
+
 let of_list l =
   let size = List.fold_left max 0 l in
   let bv = create ~size false in
   List.iter (fun i -> set bv i) l;
   bv
 
+(*$T
+  of_list [1;32;64] |> CCFun.flip get 64
+  of_list [1;32;64] |> CCFun.flip get 32
+  of_list [1;31;63] |> CCFun.flip get 63
+*)
+
 exception FoundFirst of int
 
 let first bv =
@@ -165,10 +204,19 @@ let first bv =
   with FoundFirst i ->
     i
 
+(*$T
+  of_list [50; 10; 17; 22; 3; 12] |> first = 3
+*)
+
 let filter bv p =
   iter_true bv
     (fun i -> if not (p i) then reset bv i)
 
+(*$T
+  let bv = of_list [1;2;3;4;5;6;7] in filter bv (fun x->x mod 2=0); \
+    to_sorted_list bv = [2;4;6]
+*)
+
 let union_into ~into bv =
   if length into < length bv
     then resize into (length bv);
@@ -182,6 +230,10 @@ let union bv1 bv2 =
   union_into ~into:bv bv2;
   bv
 
+(*$T
+union (of_list [1;2;3;4;5]) (of_list [7;3;5;6]) |> to_sorted_list = CCList.range 1 7
+*)
+
 let inter_into ~into bv =
   let n = min (length into) (length bv) in
   for i = 0 to n - 1 do
@@ -199,6 +251,10 @@ let inter bv1 bv2 =
       let () = inter_into ~into:bv bv1 in
       bv
 
+(*$T
+  inter (of_list [1;2;3;4]) (of_list [2;4;6;1]) |> to_sorted_list = [1;2;4]
+*)
+
 let select bv arr =
   let l = ref [] in
   begin try
@@ -222,3 +278,25 @@ let selecti bv arr =
   with Exit -> ()
   end;
   !l
+
+(*$T
+  selecti (of_list [1;4;3]) [| 0;1;2;3;4;5;6;7;8 |] \
+    |> List.sort CCOrd.compare = [1, 1; 3,3; 4,4]
+*)
+
+type 'a sequence = ('a -> unit) -> unit
+
+let to_seq bv k = iter_true bv k
+
+let of_seq seq =
+  let l = ref [] and maxi = ref 0 in
+  seq (fun x -> l := x :: !l; maxi := max !maxi x);
+  let bv = create ~size:(!maxi+1) false in
+  List.iter (fun i -> set bv i) !l;
+  bv
+
+(*$T
+  CCList.range 0 10 |> CCList.to_seq |> of_seq |> to_seq \
+    |> CCList.of_seq |> List.sort CCOrd.compare = CCList.range 0 10
+*)
+

core/CCBV.mli

@@ -73,6 +73,10 @@ val iter_true : t -> (int -> unit) -> unit
 val to_list : t -> int list
   (** List of indexes that are true *)
 
+val to_sorted_list : t -> int list
+  (** Same as {!to_list}, but also guarantees the list is sorted in
+      increasing order *)
+
 val of_list : int list -> t
   (** From a list of true bits *)
 
@@ -104,3 +108,8 @@ val select : t -> 'a array -> 'a list
 
 val selecti : t -> 'a array -> ('a * int) list
   (** Same as {!select}, but selected elements are paired with their index *)
+
+type 'a sequence = ('a -> unit) -> unit
+
+val to_seq : t -> int sequence
+val of_seq : int sequence -> t

core/CCBool.ml

@@ -30,6 +30,8 @@ let equal a b = a=b
 
 let compare a b = Pervasives.compare a b
 
+let negate x = not x
+
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
 

core/CCBool.mli

@@ -32,6 +32,8 @@ val compare : t -> t -> int
 
 val equal : t -> t -> bool
 
+val negate : t -> t
+
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
 

core/CCFQueue.ml

@@ -25,66 +25,283 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Functional queues (fifo)} *)
 
-type 'a t = {
-  hd : 'a list;
-  tl : 'a list;
-} (** Queue containing elements of type 'a *)
-
-let empty = {
-  hd = [];
-  tl = [];
-}
-
-let is_empty q = q.hd = [] && q.tl = []
-
-let push q x = {q with tl = x :: q.tl; }
-
-let rec list_last l = match l with
-  | [] -> assert false
-  | [x] -> x
-  | _::l' -> list_last l'
-
-let peek q =
-  match q.hd, q.tl with
-  | [], [] -> raise (Invalid_argument "Queue.peek")
-  | [], _::_ ->
-    list_last q.tl
-  | x::_, _ -> x
-
-(* pop first element of the queue *)
-let pop q =
-  match q.hd, q.tl with
-  | [], [] -> raise (Invalid_argument "Queue.peek")
-  | [], _::_ ->
-    (match List.rev q.tl with
-      | x::hd -> x, { hd; tl=[]; }
-      | [] -> assert false)
-  | x::_, _ ->
-    let q' = {hd=List.tl q.hd; tl=q.tl; } in
-    x, q'
-
-let junk q = snd (pop q)
-
-(** Append two queues. Elements from the second one come
-    after elements of the first one *)
-let append q1 q2 =
-  { hd=q1.hd;
-    tl=q2.tl @ (List.rev_append q2.hd q1.tl);
-  }
-
-let size q = List.length q.hd + List.length q.tl
-
-let fold f acc q =
-  let acc' = List.fold_left f acc q.hd in
-  List.fold_right (fun x acc -> f acc x) q.tl acc'
-
-let iter f q = fold (fun () x -> f x) () q
-
 type 'a sequence = ('a -> unit) -> unit
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a equal = 'a -> 'a -> bool
 
-let to_seq q = fun k -> iter k q
+(** {2 Basics} *)
 
-let of_seq seq =
+type 'a digit =
-  let q = ref empty in
+  | Zero
-  seq (fun x -> q := push !q x);
+  | One of 'a
+  | Two of 'a * 'a
+  | Three of 'a * 'a * 'a
+
+type 'a t =
+  | Shallow of 'a digit
+  | Deep of 'a digit * ('a * 'a) t lazy_t * 'a digit
+
+let empty = Shallow Zero
+
+exception Empty
+
+let _single x = Shallow (One x)
+let _double x y = Shallow (Two (x,y))
+let _deep hd middle tl =
+  assert (hd<>Zero && tl<>Zero);
+  Deep (hd, middle, tl)
+
+let is_empty = function
+  | Shallow Zero -> true
+  | _ -> false
+
+let _empty = Lazy.from_val empty
+
+let rec cons : 'a. 'a -> 'a t -> 'a t
+  = fun x q -> match q with
+  | Shallow Zero -> _single x
+  | 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 (Zero, middle, tl) -> assert false
+  | Deep (One y, middle, tl) -> _deep (Two (x,y)) middle tl
+  | Deep (Two (y,z), middle, tl) -> _deep (Three (x,y,z)) middle tl
+  | Deep (Three (y,z,z'), lazy q', tail) ->
+      _deep (Two (x,y)) (lazy (cons (z,z') q')) tail
+
+let rec snoc : 'a. 'a t -> 'a -> 'a t
+  = fun q x -> match q with
+  | Shallow Zero -> _single x
+  | 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 (hd, middle, Zero) -> assert false
+  | Deep (hd, middle, One y) -> _deep hd middle (Two(y,x))
+  | Deep (hd, middle, Two (y,z)) -> _deep hd middle (Three(y,z,x))
+  | Deep (hd, lazy q', Three (y,z,z')) ->
+      _deep 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
+  | Shallow Zero -> raise Empty
+  | 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 (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
+  | Deep (Two (x,y), middle, tail) ->
+      x, _deep (One y) middle tail
+  | Deep (Three (x,y,z), middle, tail) ->
+      x, _deep (Two(y,z)) middle tail
+
+let take_front q =
+  try Some (take_front_exn q)
+  with Empty -> None
+
+let take_front_l n q =
+  let rec aux acc q n =
+    if n=0 || is_empty q then List.rev acc, q
+    else
+      let x,q' = take_front_exn q in
+      aux (x::acc) q' (n-1)
+  in aux [] q n
+
+let take_front_while p q =
+  let rec aux acc q =
+    if is_empty q then List.rev acc, q
+    else
+      let x,q' = take_front_exn q in
+      if p x then aux (x::acc) q' else List.rev acc, q
+  in aux [] q
+
+let rec take_back_exn : 'a. 'a t -> 'a t * 'a
+  = fun q -> match q with
+  | Shallow Zero -> invalid_arg "FQueue.take_back_exn"
+  | 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, 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 (hd, middle, Two(x,y)) -> _deep hd middle (One x), y
+  | Deep (hd, middle, Three(x,y,z)) -> _deep hd middle (Two (x,y)), z
+
+let take_back q =
+  try Some (take_back_exn q)
+  with Empty -> None
+
+let take_back_l n q =
+  let rec aux acc q n =
+    if n=0 || is_empty q then q, acc
+    else
+      let q',x = take_back_exn q in
+      aux (x::acc) q' (n-1)
+  in aux [] q n
+
+let take_back_while p q =
+  let rec aux acc q =
+    if is_empty q then q, acc
+    else
+      let q',x = take_back_exn q in
+      if p x then aux (x::acc) q' else q, acc
+  in aux [] q
+
+(** {2 Individual extraction} *)
+
+let first q =
+  try Some (fst (take_front_exn q))
+  with Empty -> None
+
+let first_exn q = fst (take_front_exn q)
+
+let last q =
+  try Some (snd (take_back_exn q))
+  with Empty -> None
+
+let last_exn q = snd (take_back_exn q)
+
+let init q =
+  try fst (take_back_exn q)
+  with Empty -> q
+
+let tail q =
+  try snd (take_front_exn q)
+  with Empty -> q
+
+let add_seq_front seq q =
+  let q = ref q in
+  seq (fun x -> q := cons x !q);
   !q
+
+let add_seq_back q seq =
+  let q = ref q in
+  seq (fun x -> q := snoc !q x);
+  !q
+
+let _digit_to_seq d k = match d with
+  | Zero -> ()
+  | One x -> k x
+  | Two (x,y) -> k x; k y
+  | Three (x,y,z) -> k x; k y; k z
+
+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) ->
+      _digit_to_seq hd k;
+      to_seq q' (fun (x,y) -> k x; k y);
+      _digit_to_seq tail k
+
+let append q1 q2 =
+  match q1, q2 with
+  | Shallow Zero, _ -> q2
+  | _, Shallow Zero -> q1
+  | _ -> add_seq_front (to_seq q1) q2
+
+let _map_digit f d = match d with
+  | Zero -> Zero
+  | One x -> One (f x)
+  | Two (x,y) -> Two (f x, f y)
+  | Three (x,y,z) -> Three (f x, f y, f z)
+
+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) ->
+      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)
+
+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
+
+let _fold_digit f acc d = match d with
+  | Zero -> acc
+  | One x -> f acc x
+  | Two (x,y) -> f (f acc x) y
+  | Three (x,y,z) -> f (f (f acc x) y) z
+
+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) ->
+      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
+
+let iter f q = to_seq q f
+
+let of_list l = List.fold_left snoc empty l
+
+let to_list q =
+  let l = ref [] in
+  to_seq q (fun x -> l := x :: !l);
+  List.rev !l
+
+let of_seq seq = add_seq_front seq empty
+
+let _nil () = `Nil
+let _single x cont () = `Cons (x, cont)
+let _double x y cont () = `Cons (x, _single y cont)
+let _triple x y z cont () = `Cons (x, _double y z cont)
+
+let _digit_to_klist d cont = match d with
+  | Zero -> _nil
+  | One x -> _single x cont
+  | Two (x,y) -> _double x y cont
+  | Three (x,y,z) -> _triple x y z cont
+
+let rec _flat_klist : 'a. ('a * 'a) klist -> 'a klist -> 'a klist
+  = fun l cont () -> match l () with
+  | `Nil -> cont ()
+  | `Cons ((x,y),l') -> _double x y (_flat_klist l' cont) ()
+
+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) ->
+        _digit_to_klist hd
+          (_flat_klist
+            (aux q' _nil)
+            (_digit_to_klist tl cont))
+          ()
+  in
+  aux q _nil
+
+let of_klist l =
+  let rec seq l k = match l() with
+    | `Nil -> ()
+    | `Cons(x,l') -> k x; seq l' k
+  in
+  add_seq_front (seq l) empty
+
+let rec _equal_klist eq l1 l2 = match l1(), l2() with
+  | `Nil, `Nil -> true
+  | `Nil, _
+  | _, `Nil -> false
+  | `Cons(x1,l1'), `Cons(x2,l2') ->
+      eq x1 x2 && _equal_klist eq l1' l2'
+
+let equal eq q1 q2 = _equal_klist eq (to_klist q1) (to_klist q2)

core/CCFQueue.mli

@@ -23,39 +23,107 @@ 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 Functional queues (fifo)} *)
+(** {1 Functional queues} *)
 
-type 'a t
+type 'a sequence = ('a -> unit) -> unit
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a equal = 'a -> 'a -> bool
+
+(** {2 Basics} *)
+
+type +'a t
   (** Queue containing elements of type 'a *)
 
 val empty : 'a t
 
 val is_empty : 'a t -> bool
 
-val push : 'a t -> 'a -> 'a t
+exception Empty
-  (** Push element at the end of the queue *)
 
-val peek : 'a t -> 'a
+val cons : 'a -> 'a t -> 'a t
-  (** Get first element, or raise Invalid_argument *)
+(** Push element at the front of the queue *)
 
-val pop : 'a t -> 'a * 'a t
+val snoc : 'a t -> 'a -> 'a t
-  (** Get and remove the first element, or raise Invalid_argument *)
+(** Push element at the end of the queue *)
 
-val junk : 'a t -> 'a t
+val take_front : 'a t -> ('a * 'a t) option
-  (** Remove first element. If queue is empty, do nothing. *)
+(** Get and remove the first element *)
+
+val take_front_exn : 'a t -> ('a * 'a t)
+(** Same as {!take_front}, but fails on empty queues.
+    @raise Empty if the queue is empty *)
+
+val take_front_l : int -> 'a t -> 'a list * 'a t
+(** [take_front_l n q] takes at most [n] elements from the front
+    of [q], and returns them wrapped in a list *)
+
+val take_front_while : ('a -> bool) -> 'a t -> 'a list * 'a t
+
+val take_back : 'a t -> ('a t * 'a) option
+(** Take last element *)
+
+val take_back_exn : 'a t -> ('a t * 'a)
+
+val take_back_l : int -> 'a t -> 'a t * 'a list
+(** [take_back_l n q] removes and returns the last [n] elements of [q]. The
+    elements are in the order of the queue, that is, the head of the returned
+    list is the first element to appear via {!take_front}.
+    [take_back_l 2 (of_list [1;2;3;4]) = of_list [1;2], [3;4]] *)
+
+val take_back_while : ('a -> bool) -> 'a t -> 'a t * 'a list
+
+(** {2 Individual extraction} *)
+
+val first : 'a t -> 'a option
+(** First element of the queue *)
+
+val last : 'a t -> 'a option
+(** Last element of the queue *)
+
+val first_exn : 'a t -> 'a
+(** Same as {!peek} but
+    @raise Empty if the queue is empty *)
+
+val last_exn : 'a t -> 'a
+
+val tail : 'a t -> 'a t
+(** Queue deprived of its first element. Does nothing on empty queues *)
+
+val init : 'a t -> 'a t
+(** Queue deprived of its last element. Does nothing on empty queues *)
+
+(** {2 Global Operations} *)
 
 val append : 'a t -> 'a t -> 'a t
   (** Append two queues. Elements from the second one come
-      after elements of the first one *)
+      after elements of the first one.
+      Linear in the size of the second queue. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Map values *)
+
+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 (linear in time) *)
 
 val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
 
 val iter : ('a -> unit) -> 'a t -> unit
 
-type 'a sequence = ('a -> unit) -> unit
+val equal : 'a equal -> 'a t equal
+
+(** {2 Conversions} *)
+
+val of_list : 'a list -> 'a t
+val to_list : 'a t -> 'a list
+
+val add_seq_front : 'a sequence -> 'a t -> 'a t
+val add_seq_back : 'a t -> 'a sequence -> 'a t
+
 val to_seq : 'a t -> 'a sequence
 val of_seq : 'a sequence -> 'a t
 
+val to_klist : 'a t -> 'a klist
+val of_klist : 'a klist -> 'a t
+

core/CCHash.ml

@@ -26,50 +26,72 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 (** {1 Hash combinators} *)
 
 type t = int
-type 'a hash_fun = 'a -> t
+type state = int64
+type 'a hash_fun = 'a -> state -> state
 
-let combine hash i =
+let _r = 47
-  (hash * 65599 + i) land max_int
+let _m = 0xc6a4a7935bd1e995L
 
-let (<<>>) = combine
+let init = _m  (* TODO? *)
 
-let hash_int i = combine 0 i
+(* combine key [k] with the current state [s] *)
+let _combine s k =
+  let k = Int64.mul _m k in
+  let k = Int64.logxor k (Int64.shift_right k _r) in
+  let k = Int64.mul _m k in
+  let s = Int64.logxor s k in
+  let s = Int64.mul _m s in
+  s
 
-let hash_int2 i j = combine i j
+let finish s =
+  let s = Int64.logxor s (Int64.shift_right s _r) in
+  let s = Int64.mul s _m in
+  let s = Int64.logxor s (Int64.shift_right s _r) in
+  (Int64.to_int s) land max_int
 
-let hash_int3 i j k = combine (combine i j) k
+let apply f x = finish (f x init)
 
-let hash_int4 i j k l =
+(** {2 Combinators} *)
-  combine (combine (combine i j) k) l
 
-let rec hash_list f h l = match l with
+let int_ i s = _combine s (Int64.of_int i)
-  | [] -> h
+let bool_ x s = _combine s (if x then 1L else 2L)
-  | x::l' -> hash_list f (combine h (f x)) l'
+let char_ x s = _combine s (Int64.of_int (Char.code x))
+let int32_ x s = _combine s (Int64.of_int32 x)
+let int64_ x s = _combine s x
+let nativeint_ x s = _combine s (Int64.of_nativeint x)
+let string_ x s =
+  let s = ref s in
+  String.iter (fun c -> s := char_ c !s) x;
+  !s
 
-let hash_array f h a =
+let rec list_ f l s = match l with
-  let h = ref h in
+  | [] -> s
-  Array.iter (fun x -> h := combine !h (f x)) a;
+  | x::l' -> list_ f l' (f x s)
-  !h
 
-let hash_string s = Hashtbl.hash s
+let array_ f a s = Array.fold_right f a s
 
-let hash_pair h1 h2 (x,y) = combine (h1 x) (h2 y)
+let opt f o h = match o with
-let hash_triple h1 h2 h3 (x,y,z) = (h1 x) <<>> (h2 y) <<>> (h3 z)
+  | None -> h
+  | Some x -> f x h
+let pair h1 h2 (x,y) s = h2 y (h1 x s)
+let triple h1 h2 h3 (x,y,z) s = h3 z (h2 y (h1 x s))
+
+let if_ b then_ else_ h =
+  if b then then_ h else else_ h
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 
-let hash_seq f h seq =
+let seq f seq s =
-  let h = ref h in
+  let s = ref s in
-  seq (fun x -> h := !h <<>> f x);
+  seq (fun x -> s := f x !s);
-  !h
+  !s
 
-let rec hash_gen f h g = match g () with
+let rec gen f g s = match g () with
-  | None -> h
+  | None -> s
-  | Some x ->
+  | Some x -> gen f g (f x s)
-      hash_gen f (h <<>> f x) g
 
-let rec hash_klist f h l = match l () with
+let rec klist f l s = match l () with
-  | `Nil -> h
+  | `Nil -> s
-  | `Cons (x,l') -> hash_klist f (h <<>> f x) l'
+  | `Cons (x,l') -> klist f l' (f x s)

core/CCHash.mli

@@ -25,40 +25,57 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Hash combinators}
 
-Combination of hashes based on the
+Combination of hashes based on the Murmur Hash (64 bits). See
-SDBM simple hash (see for instance
+{{: https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} this page}
-{{:http://www.cse.yorku.ca/~oz/hash.html} this page})
 *)
 
+(** {2 Definitions} *)
+
 type t = int
+(** A hash value is a positive integer *)
 
-type 'a hash_fun = 'a -> t
+type state = int64
+(** State required by the hash function *)
 
-val combine : t -> t -> t
+type 'a hash_fun = 'a -> state -> state
-  (** Combine two hashes. Non-commutative. *)
+(** Hash function for values of type ['a], merging a fingerprint of the
+    value into the state of type [t] *)
 
-val (<<>>) : t -> t -> t
+val init : state
-  (** Infix version of {!combine} *)
+(** Initial value *)
 
-val hash_int : int -> t
+val finish : state -> int
-val hash_int2 : int -> int -> t
+(** Extract a usable hash value *)
-val hash_int3 : int -> int -> int -> t
-val hash_int4 : int -> int -> int -> int -> t
 
-val hash_string : string -> t
+val apply : 'a hash_fun -> 'a -> int
+(** Apply a hash function to a value *)
 
-val hash_list : 'a hash_fun -> t -> 'a list hash_fun
+(** {2 Basic Combinators} *)
+
+val bool_ : bool hash_fun
+val char_ : char hash_fun
+val int_ : int hash_fun
+val string_ : string hash_fun
+val int32_ : int32 hash_fun
+val int64_ : int64 hash_fun
+val nativeint_ : nativeint hash_fun
+
+val list_ : 'a hash_fun -> 'a list hash_fun
 (** Hash a list. Each element is hashed using [f]. *)
 
-val hash_array : 'a hash_fun -> t -> 'a array hash_fun
+val array_ : 'a hash_fun -> 'a array hash_fun
 
-val hash_pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun
+val opt : 'a hash_fun -> 'a option hash_fun
-val hash_triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun
+val pair : 'a hash_fun -> 'b hash_fun -> ('a * 'b) hash_fun
+val triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun
+
+val if_ : bool -> 'a hash_fun -> 'a hash_fun -> 'a hash_fun
+(** Decide which hash function to use depending on the boolean *)
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 
-val hash_seq : 'a hash_fun -> t -> 'a sequence hash_fun
+val seq : 'a hash_fun -> 'a sequence hash_fun
-val hash_gen : 'a hash_fun -> t -> 'a gen hash_fun
+val gen : 'a hash_fun -> 'a gen hash_fun
-val hash_klist : 'a hash_fun -> t -> 'a klist hash_fun
+val klist : 'a hash_fun -> 'a klist hash_fun

core/CCHeap.ml

@@ -0,0 +1,240 @@
+(*
+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 Leftist Heaps} *)
+
+type 'a sequence = ('a -> unit) -> unit
+type 'a gen = unit -> 'a option
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
+
+module type PARTIAL_ORD = sig
+  type t
+  val leq : t -> t -> bool
+  (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *)
+end
+
+module type S = sig
+  type elt
+  type t
+
+  val empty : t
+  (** Empty heap *)
+
+  val is_empty : t -> bool
+  (** Is the heap empty? *)
+
+  exception Empty
+
+  val merge : t -> t -> t
+  (** Merge two heaps *)
+
+  val insert : elt -> t -> t
+  (** Insert a value in the heap *)
+
+  val add : t -> elt -> t
+  (** Synonym to {!insert} *)
+
+  val filter :  (elt -> bool) -> t -> t
+  (** Filter values, only retaining the ones that satisfy the predicate.
+      Linear time at least. *)
+
+  val find_min : t -> elt option
+  (** Find minimal element *)
+
+  val find_min_exn : t -> elt
+  (** Same as {!find_min} but can fail
+      @raise Empty if the heap is empty *)
+
+  val take : t -> (t * elt) option
+  (** Extract and return the minimum element, and the new heap (without
+      this element), or [None] if the heap is empty *)
+
+  val take_exn : t -> t * elt
+  (** Same as {!take}, but can fail.
+      @raise Empty if the heap is empty *)
+
+  val iter : (elt -> unit) -> t -> unit
+  (** Iterate on elements *)
+
+  val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a
+  (** Fold on all values *)
+
+  val size : t -> int
+  (** Number of elements (linear complexity) *)
+
+  (** {2 Conversions} *)
+
+  val to_list : t -> elt list
+  val of_list : elt list -> t
+
+  val of_seq : t -> elt sequence -> t
+  val to_seq : t -> elt sequence
+
+  val of_klist : t -> elt klist -> t
+  val to_klist : t -> elt klist
+
+  val of_gen : t -> elt gen -> t
+  val to_gen : t -> elt gen
+
+  val to_tree : t -> elt tree
+end
+
+module Make(E : PARTIAL_ORD) = struct
+  type elt = E.t
+
+  type t =
+    | E
+    | N of int * elt * t * t
+
+  let empty = E
+
+  let is_empty = function
+    | E -> true
+    | N _ -> false
+
+  exception Empty
+
+  (* Rank of the tree *)
+  let _rank = function
+    | E -> 0
+    | N (r, _, _, _) -> r
+
+  (* Make a balanced node labelled with [x], and subtrees [a] and [b].
+    We ensure that the right child's rank is ≤ to the rank of the
+    left child (leftist property). The rank of the resulting node
+    is the length of the rightmost path. *)
+  let _make_node x a b =
+    if _rank a >= _rank b
+      then N (_rank b + 1, x, a, b)
+      else N (_rank a + 1, x, b, a)
+
+  let rec merge t1 t2 =
+    match t1, t2 with
+    | t, E -> t
+    | E, t -> t
+    | N (_, x, a1, b1), N (_, y, a2, b2) ->
+      if E.leq x y
+        then _make_node x a1 (merge b1 t2)
+        else _make_node y a2 (merge t1 b2)
+
+  let insert x h =
+    merge (N(1,x,E,E)) h
+
+  let add h x = insert x h
+
+  let rec filter p h = match h with
+    | E -> E
+    | N(_, x, l, r) when p x -> _make_node x (filter p l) (filter p r)
+    | N(_, _, l, r) ->
+        merge (filter p l) (filter p r)
+
+  let find_min_exn = function
+    | E -> raise Empty
+    | N (_, x, _, _) -> x
+
+  let find_min = function
+    | E -> None
+    | N (_, x, _, _) -> Some x
+
+  let take = function
+    | E -> None
+    | N (_, x, l, r) -> Some (merge l r, x)
+
+  let take_exn = function
+    | E -> raise Empty
+    | N (_, x, l, r) -> merge l r, x
+
+  let rec iter f h = match h with
+    | E -> ()
+    | N(_,x,l,r) -> f x; iter f l; iter f r
+
+  let rec fold f acc h = match h with
+    | E -> acc
+    | N (_, x, a, b) ->
+        let acc = f acc x in
+        let acc = fold f acc a in
+        fold f acc b
+
+  let rec size = function
+    | E -> 0
+    | N (_,_,l,r) -> 1 + size l + size r
+
+  (** {2 Conversions} *)
+
+  let to_list h =
+    let rec aux acc h = match h with
+      | E -> acc
+      | N(_,x,l,r) ->
+          x::aux (aux acc l) r
+    in aux [] h
+
+  let of_list l = List.fold_left add empty l
+
+  let of_seq h seq =
+    let h = ref h in
+    seq (fun x -> h := insert x !h);
+    !h
+
+  let to_seq h k = iter k h
+
+  let rec of_klist h l = match l() with
+    | `Nil -> h
+    | `Cons (x, l') ->
+        let h' = add h x in
+        of_klist h' l'
+
+  let to_klist h =
+    let rec next stack () = match stack with
+      | [] -> `Nil
+      | E :: stack' -> next stack' ()
+      | N (_, x, a, b) :: stack' ->
+          `Cons (x, next (a :: b :: stack'))
+    in
+    next [h]
+
+  let rec of_gen h g = match g () with
+    | None -> h
+    | Some x ->
+        of_gen (add h x) g
+
+  let to_gen h =
+    let stack = Stack.create () in
+    Stack.push h stack;
+    let rec next () =
+      if Stack.is_empty stack
+      then None
+      else match Stack.pop stack with
+        | E -> next()
+        | N (_, x, a, b) ->
+            Stack.push a stack;
+            Stack.push b stack;
+            Some x
+    in next
+
+  let rec to_tree h () = match h with
+    | E -> `Nil
+    | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r])
+end

core/CCHeap.mli

@@ -23,65 +23,83 @@ 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 Leftist Heaps}
+(** {1 Leftist Heaps} following Okasaki *)
-Polymorphic implementation, following Okasaki *)
 
 type 'a sequence = ('a -> unit) -> unit
-type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a gen = unit -> 'a option
+type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
 
-type 'a t
+module type PARTIAL_ORD = sig
-  (** Heap containing values of type 'a *)
+  type t
+  val leq : t -> t -> bool
+  (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *)
+end
 
-val empty_with : leq:('a -> 'a -> bool) -> 'a t
+module type S = sig
-  (** Empty heap. The function is used to check whether the first element is
+  type elt
-      smaller than the second. *)
+  type t
 
-val empty : 'a t
+  val empty : t
-  (** Empty heap using [Pervasives.compare] *)
+  (** Empty heap *)
 
-val is_empty : _ t -> bool
+  val is_empty : t -> bool
   (** Is the heap empty? *)
 
-val merge : 'a t -> 'a t -> 'a t
+  exception Empty
-  (** Merge two heaps (assume they have the same comparison function) *)
 
-val insert : 'a t -> 'a -> 'a t
+  val merge : t -> t -> t
+  (** Merge two heaps *)
+
+  val insert : elt -> t -> t
   (** Insert a value in the heap *)
 
-val add : 'a t -> 'a -> 'a t
+  val add : t -> elt -> t
   (** Synonym to {!insert} *)
 
-val filter : 'a t -> ('a -> bool) -> 'a t
+  val filter :  (elt -> bool) -> t -> t
   (** Filter values, only retaining the ones that satisfy the predicate.
       Linear time at least. *)
 
-val find_min : 'a t -> 'a
+  val find_min : t -> elt option
-  (** Find minimal element, or fails
+  (** Find minimal element *)
-      @raise Not_found if the heap is empty *)
 
-val extract_min : 'a t -> 'a t * 'a
+  val find_min_exn : t -> elt
-  (** Extract and returns the minimal element, or
+  (** Same as {!find_min} but can fail
-      raise Not_found if the heap is empty *)
+      @raise Empty if the heap is empty *)
 
-val take : 'a t -> ('a * 'a t) option
+  val take : t -> (t * elt) option
   (** Extract and return the minimum element, and the new heap (without
       this element), or [None] if the heap is empty *)
 
-val iter : ('a -> unit) -> 'a t -> unit
+  val take_exn : t -> t * elt
+  (** Same as {!take}, but can fail.
+      @raise Empty if the heap is empty *)
+
+  val iter : (elt -> unit) -> t -> unit
   (** Iterate on elements *)
 
-val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+  val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a
   (** Fold on all values *)
 
-val size : _ t -> int
+  val size : t -> int
   (** Number of elements (linear complexity) *)
 
-val of_seq : 'a t -> 'a sequence -> 'a t
+  (** {2 Conversions} *)
-val to_seq : 'a t -> 'a sequence
 
-val of_klist : 'a t -> 'a klist -> 'a t
+  val to_list : t -> elt list
-val to_klist : 'a t -> 'a klist
+  val of_list : elt list -> t
 
-val of_gen : 'a t -> 'a gen -> 'a t
+  val of_seq : t -> elt sequence -> t
-val to_gen : 'a t -> 'a gen
+  val to_seq : t -> elt sequence
+
+  val of_klist : t -> elt klist -> t
+  val to_klist : t -> elt klist
+
+  val of_gen : t -> elt gen -> t
+  val to_gen : t -> elt gen
+
+  val to_tree : t -> elt tree
+end
+
+module Make(E : PARTIAL_ORD) : S with type elt = E.t

core/CCInt.ml

@@ -39,6 +39,11 @@ let sign i =
 
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+let random n st = Random.State.int st n
+let random_small = random 100
+let random_range i j st = i + random (j-i) st
 
 let pp buf = Printf.bprintf buf "%d"
 let print fmt = Format.fprintf fmt "%d"

core/CCInt.mli

@@ -39,6 +39,11 @@ val sign : t -> int
 
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+val random : int -> t random_gen
+val random_small : t random_gen
+val random_range : int -> int -> t random_gen
 
 val pp : t printer
 val print : t formatter

core/CCKList.ml

@@ -237,6 +237,33 @@ let to_gen l =
         l := l';
         Some x
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  open M
+
+  let map_m f l =
+    let rec aux acc l = match l () with
+      | `Nil -> return (of_list (List.rev acc))
+      | `Cons (x,l') ->
+          f x >>= fun x' ->
+          aux (x' :: acc) l'
+    in
+    aux [] l
+
+  let sequence_m l = map_m (fun x->x) l
+
+  let rec fold_m f acc l = match l() with
+    | `Nil -> return acc
+    | `Cons (x,l') ->
+        f acc x >>= fun acc' -> fold_m f acc' l'
+end
+
 (** {2 IO} *)
 
 let pp ?(sep=",") pp_item buf l =

core/CCKList.mli

@@ -106,6 +106,21 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
 val merge : 'a ord -> 'a t -> 'a t -> 'a t
 (** Merge two sorted iterators into a sorted iterator *)
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : 'a M.t t -> 'a t M.t
+
+  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
+end
+
 (** {2 Conversions} *)
 
 val of_list : 'a list -> 'a t

core/CCLeftistheap.ml

@@ -1,180 +0,0 @@
-(*
-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 Leftist Heaps} *)
-
-(** Polymorphic implementation, following Okasaki *)
-
-type 'a sequence = ('a -> unit) -> unit
-type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
-type 'a gen = unit -> 'a option
-
-type 'a t = {
-  tree : 'a tree;
-  leq : 'a -> 'a -> bool;
-} (** Empty heap. The function is used to check whether
-      the first element is smaller than the second. *)
-and 'a tree =
-  | Empty
-  | Node of int * 'a * 'a tree * 'a tree
-
-let empty_with ~leq =
-  { tree = Empty;
-    leq;
-  }
-
-let empty =
-  { tree = Empty;
-    leq = (fun x y -> x <= y);
-  }
-
-let is_empty heap =
-  match heap.tree with
-  | Empty -> true
-  | _ -> false
-
-(** Rank of the tree *)
-let rank_tree t = match t with
-  | Empty -> 0
-  | Node (r, _, _, _) -> r
-
-(** Make a balanced node labelled with [x], and subtrees [a] and [b] *)
-let make_node x a b =
-  if rank_tree a >= rank_tree b
-    then Node (rank_tree b + 1, x, a, b)
-    else Node (rank_tree a + 1, x, b, a)
-
-let rec merge_tree leq t1 t2 =
-  match t1, t2 with
-  | t, Empty -> t
-  | Empty, t -> t
-  | Node (_, x, a1, b1), Node (_, y, a2, b2) ->
-    if leq x y
-      then make_node x a1 (merge_tree leq b1 t2)
-      else make_node y a2 (merge_tree leq t1 b2)
-
-let merge h1 h2 =
-  let tree = merge_tree h1.leq h1.tree h2.tree in
-  { tree; leq=h1.leq; }
-
-let insert heap x =
-  let tree = merge_tree heap.leq (Node (1, x, Empty, Empty)) heap.tree in
-  { heap with tree; }
-
-let add = insert
-
-let filter heap p =
-  let rec filter tree p = match tree with
-  | Empty -> Empty
-  | Node (_, x, l, r) when p x ->
-    merge_tree heap.leq (Node (1, x, Empty, Empty))
-      (merge_tree heap.leq (filter l p) (filter r p))
-  | Node (_, _, l, r) -> merge_tree heap.leq (filter l p) (filter r p)
-  in
-  { heap with tree = filter heap.tree p; }
-
-let find_min heap =
-  match heap.tree with
-  | Empty -> raise Not_found
-  | Node (_, x, _, _) -> x
-
-let extract_min heap =
-  match heap.tree with
-  | Empty -> raise Not_found
-  | Node (_, x, a, b) ->
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    heap', x
-
-let take heap = match heap.tree with
-  | Empty -> None
-  | Node (_, x, a, b) ->
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    Some (x, heap')
-
-let iter f heap =
-  let rec iter t = match t with
-    | Empty -> ()
-    | Node (_, x, a, b) ->
-      f x;
-      iter a;
-      iter b;
-  in iter heap.tree
-
-let fold f acc h =
-  let rec fold acc h = match h with
-    | Empty -> acc
-    | Node (_, x, a, b) ->
-        let acc = f acc x in
-        let acc = fold acc a in
-        fold acc b
-  in fold acc h.tree
-
-let size heap =
-  let r = ref 0 in
-  iter (fun _ -> incr r) heap;
-  !r
-
-let of_seq heap seq =
-  let h = ref heap in
-  seq (fun x -> h := insert !h x);
-  !h
-
-let to_seq h k = iter k h
-
-let rec of_klist h l = match l() with
-  | `Nil -> h
-  | `Cons (x, l') ->
-      let h' = add h x in
-      of_klist h' l'
-
-let to_klist h =
-  let rec next stack () = match stack with
-    | [] -> `Nil
-    | Empty :: stack' -> next stack' ()
-    | Node (_, x, a, b) :: stack' ->
-        `Cons (x, next (a :: b :: stack'))
-  in
-  next [h.tree]
-
-let rec of_gen h g = match g () with
-  | None -> h
-  | Some x ->
-      of_gen (add h x) g
-
-let to_gen h =
-  let stack = Stack.create () in
-  Stack.push h.tree stack;
-  let rec next () =
-    if Stack.is_empty stack
-    then None
-    else match Stack.pop stack with
-      | Empty -> next()
-      | Node (_, x, a, b) ->
-          Stack.push a stack;
-          Stack.push b stack;
-          Some x
-  in next

core/CCList.ml

@@ -378,11 +378,22 @@ let range i j =
   range 5 2 = [5;4;3;2]
 *)
 
+let range' i j =
+  if i<j then range i (j-1)
+  else if i=j then []
+  else range i (j+1)
+
+(*$T
+  range' 0 0 = []
+  range' 0 5 = [0;1;2;3;4]
+  range' 5 2 = [5;4;3]
+*)
+
 let (--) = range
 
 (*$T
   append (range 0 100) (range 101 1000) = range 0 1000
-  append (range 1000 500) (range 499 0) = range 1000 0
+  append (range 1000 501) (range 500 0) = range 1000 0
 *)
 
 let replicate i x =
@@ -484,6 +495,34 @@ module Zipper = struct
     | _, [] -> raise Not_found
 end
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  open M
+
+  let map_m f l =
+    let rec aux f acc l = match l with
+      | [] -> return (List.rev acc)
+      | x::tail ->
+          f x >>= fun x' ->
+          aux f (x' :: acc) tail
+    in aux f [] l
+
+  let sequence_m l = map_m (fun x->x) l
+
+  let rec fold_m f acc l = match l with
+    | [] -> return acc
+    | x :: l' ->
+        f acc x
+        >>= fun acc' ->
+        fold_m f acc' l'
+end
+
 (** {2 Conversions} *)
 
 type 'a sequence = ('a -> unit) -> unit
@@ -491,6 +530,32 @@ type 'a gen = unit -> 'a option
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+let random_len len g st =
+  map (fun _ -> g st) (range' 0 len)
+
+(*$T
+  random_len 10 CCInt.random_small (Random.State.make [||]) |> List.length = 10
+*)
+
+let random g st =
+  let len = Random.State.int st 1_000 in
+  random_len len g st
+
+let random_non_empty g st =
+  let len = 1 + Random.State.int st 1_000 in
+  random_len len g st
+
+let random_choose l = match l with
+  | [] -> raise Not_found
+  | _::_ ->
+      let len = List.length l in
+      fun st ->
+        let i = Random.State.int st len in
+        List.nth l i
+
+let random_sequence l st = map (fun g -> g st) l
 
 let to_seq l k = List.iter k l
 let of_seq seq =

core/CCList.mli

@@ -152,9 +152,13 @@ end
 (** {2 Other Constructors} *)
 
 val range : int -> int -> int t
-(** [range i j] iterates on integers from [i] to [j] included. It works
+(** [range i j] iterates on integers from [i] to [j] included . It works
     both for decreasing and increasing ranges *)
 
+val range' : int -> int -> int t
+(** Same as {!range} but the second bound is excluded.
+    For instance [range' 0 5 = [0;1;2;3;4]] *)
+
 val (--) : int -> int -> int t
 (** Infix alias for [range] *)
 
@@ -216,6 +220,21 @@ module Zipper : sig
       @raise Not_found if the zipper is at an end *)
 end
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : 'a M.t t -> 'a t M.t
+
+  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
+end
+
 (** {2 Conversions} *)
 
 type 'a sequence = ('a -> unit) -> unit
@@ -223,6 +242,17 @@ type 'a gen = unit -> 'a option
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+val random : 'a random_gen -> 'a t random_gen
+val random_non_empty : 'a random_gen -> 'a t random_gen
+val random_len : int -> 'a random_gen -> 'a t random_gen
+
+val random_choose : 'a t -> 'a random_gen
+(** Randomly choose an element in the list.
+    @raise Not_found if the list is empty *)
+
+val random_sequence : 'a random_gen t -> 'a t random_gen
 
 val to_seq : 'a t -> 'a sequence
 val of_seq : 'a sequence -> 'a t

core/CCOpt.ml

@@ -95,6 +95,10 @@ let of_list = function
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a printer = Buffer.t -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+let random g st =
+  if Random.State.bool st then Some (g st) else None
 
 let to_gen o =
   match o with

core/CCOpt.mli

@@ -74,6 +74,9 @@ val of_list : 'a list -> 'a t
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 type 'a printer = Buffer.t -> 'a -> unit
+type 'a random_gen = Random.State.t -> 'a
+
+val random : 'a random_gen -> 'a t random_gen
 
 val to_gen : 'a t -> 'a gen
 val to_seq : 'a t -> 'a sequence

core/CCRandom.ml

@@ -0,0 +1,169 @@
+
+(*
+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 Random Generators} *)
+
+type state = Random.State.t
+
+type 'a t = state -> 'a
+type 'a random_gen = 'a t
+
+let return x _st = x
+
+let flat_map f g st = f (g st) st
+
+let (>>=) g f st = flat_map f g st
+
+let map f g st = f (g st)
+
+let (>|=) g f st = map f g st
+
+let _choose_array a st =
+  if Array.length a = 0 then invalid_arg "CCRandom.choose_array";
+  a.(Random.State.int st (Array.length a))
+
+let choose_array a st =
+  try Some (_choose_array a st st) with Invalid_argument _ -> None
+
+let choose l =
+  let a = Array.of_list l in
+  choose_array a
+
+let choose_exn l =
+  let a = Array.of_list l in
+  fun st -> _choose_array a st st
+
+let choose_return l = _choose_array (Array.of_list l)
+
+let int i st = Random.State.int st i
+
+let small_int = int 100
+
+let int_range i j st = i + Random.State.int st (j-i+1)
+
+let replicate n g st =
+  let rec aux acc n =
+    if n = 0 then acc else aux (g st :: acc) (n-1)
+  in aux [] n
+
+exception SplitFail
+
+let _split i st =
+  if i < 2 then raise SplitFail
+  else
+    let j = 1 + Random.State.int st (i-1) in
+    (j, i-j)
+
+let split i st = try Some (_split i st) with SplitFail -> None
+
+(* partition of an int into [len] integers. We divide-and-conquer on
+  the expected length, until it reaches 1. *)
+let split_list i ~len st =
+  let rec aux i ~len acc =
+    if i < len then raise SplitFail
+    else if len = 1 then i::acc
+    else
+      (* split somewhere in the middle *)
+      let len1, len2 = _split len st in
+      assert (len = len1+len2);
+      if i = len
+      then aux len1 ~len:len1 (aux len2 ~len:len2 acc)
+      else
+        let i1, i2 = _split (i-len) st in
+        aux (i1+len1) ~len:len1 (aux (i2+len2) ~len:len2 acc)
+  in
+  try Some (aux i ~len []) with SplitFail -> None
+
+let retry ?(max=10) g st =
+  let rec aux n =
+    match g st with
+      | None when n=0 -> None
+      | None -> aux (n-1)  (* retry *)
+      | Some _ as res -> res
+  in
+  aux max
+
+let rec try_successively l st = match l with
+  | [] -> None
+  | g :: l' ->
+      begin match g st with
+      | None -> try_successively l' st
+      | Some _ as res -> res
+      end
+
+let (<?>) a b = try_successively [a;b]
+
+exception Backtrack
+
+let _choose_array_call a f st =
+  try
+    f (_choose_array a st)
+  with Invalid_argument _ -> raise Backtrack
+
+let fix ?(sub1=[]) ?(sub2=[]) ?(subn=[]) ~base fuel st =
+  let sub1 = Array.of_list sub1
+  and sub2 = Array.of_list sub2
+  and subn = Array.of_list subn in
+  (* recursive function with fuel *)
+  let rec make fuel st =
+    if fuel=0 then raise Backtrack
+    else if fuel=1 then base st
+    else
+      _try_otherwise 0
+        [| _choose_array_call sub1 (fun f -> f (make (fuel-1)) st)
+        ;  _choose_array_call sub2
+          (fun f ->
+            match split fuel st with
+            | None -> raise Backtrack
+            | Some (i,j) -> f (make i) (make j) st
+          )
+        ; _choose_array_call subn
+          (fun (len,f) ->
+            let len = len st in
+            match split_list fuel ~len st with
+            | None -> raise Backtrack
+            | Some l' ->
+                f (fun st -> List.map (fun x -> make x st) l') st
+          )
+        ; base (* base case then *)
+        |]
+  and _try_otherwise i a =
+    if i=Array.length a then raise Backtrack
+    else try
+      a.(i) st
+    with Backtrack ->
+      _try_otherwise (i+1) a
+  in
+  make (fuel st) st
+
+let pure x _st = x
+
+let (<*>) f g st = f st (g st)
+
+let __default_state = Random.State.make_self_init ()
+
+let run ?(st=__default_state) g = g st
+

core/CCRandom.mli

@@ -0,0 +1,116 @@
+
+(*
+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 Random Generators} *)
+
+type state = Random.State.t
+
+type 'a t = state -> 'a
+(** Random generator for values of type ['a] *)
+
+type 'a random_gen = 'a t
+
+val return : 'a -> 'a t
+(** [return x] is the generator that always returns [x].
+    Example:  [let random_int = return 4 (* fair dice roll *)] *)
+
+val flat_map : ('a -> 'b t) -> 'a t -> 'b t
+
+val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+
+val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+
+val choose : 'a t list -> 'a option t
+(** Choose a generator within the list. *)
+
+val choose_exn : 'a t list -> 'a t
+(** Same as {!choose} but without option.
+    @raise Invalid_argument if the list is empty *)
+
+val choose_array : 'a t array -> 'a option t
+
+val choose_return : 'a list -> 'a t
+(** Choose among the list
+    @raise Invalid_argument if the list is empty *)
+
+val replicate : int -> 'a t -> 'a list t
+
+val small_int : int t
+
+val int : int -> int t
+
+val int_range : int -> int -> int t
+(** Inclusive range *)
+
+val split : int -> (int * int) option t
+(** Split a positive value [n] into [n1,n2] where [n = n1 + n2].
+    @return [None] if the value is too small *)
+
+val split_list : int -> len:int -> int list option t
+(** Split a value [n] into a list of values whose sum is [n]
+    and whose length is [length].
+    @return [None] if the value is too small *)
+
+val retry : ?max:int -> 'a option t -> 'a option t
+(** [retry g] calls [g] until it returns some value, or until the maximum
+    number of retries was reached. If [g] fails,
+    then it counts for one iteration, and the generator retries.
+    @param max: maximum number of retries. Default [10] *)
+
+val try_successively : 'a option t list -> 'a option t
+(** [try_successively l] tries each generator of [l], one after the other.
+    If some generator succeeds its result is returned, else the
+    next generator is tried *)
+
+val (<?>) : 'a option t -> 'a option t -> 'a option t
+(** [a <?> b] is a choice operator. It first tries [a], and returns its
+    result if successful. If [a] fails, then [b] is returned. *)
+
+val fix :
+  ?sub1:('a t -> 'a t) list ->
+  ?sub2:('a t -> 'a t -> 'a t) list ->
+  ?subn:(int t * ('a list t -> 'a t)) list ->
+  base:'a t -> int t -> 'a t
+(** Recursion combinators, for building recursive values.
+    The integer generator is used to provide fuel. The [sub_] generators
+    should use their arguments only once!
+    @param sub1 cases that recurse on one value
+    @param sub2 cases that use the recursive gen twice
+    @param subn cases that use a list of recursive cases *)
+
+(** {6 Applicative} *)
+
+val pure : 'a -> 'a t
+
+val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
+
+(** {6 Run a generator} *)
+
+val run : ?st:state -> 'a t -> 'a
+(** Using a random state (possibly the one in argument) run a generator *)
+

core/CCSequence.mli

@@ -53,8 +53,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     of this memory structure, cheaply and repeatably. *)
 
 type +'a t = ('a -> unit) -> unit
-  (** Sequence abstract iterator type, representing a finite sequence of
+  (** Sequence iterator type, representing a finite sequence of values
-      values of type ['a]. *)
+      of type ['a] that one can iterate on. *)
 
 type +'a sequence = 'a t
 

core/_tags

@@ -0,0 +1 @@
+<CCHash.*>: inline(20)

core/containers.mldylib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: de6b01e36860e123951867ef27ec6b0b)
+# DO NOT EDIT (digest: 8d0afff73fae73db9a0364afaa57d4d2)
 CCVector
 CCDeque
 CCGen
@@ -11,7 +11,7 @@ CCBV
 CCPrint
 CCPersistentHashtbl
 CCError
-CCLeftistheap
+CCHeap
 CCList
 CCOpt
 CCPair
@@ -23,5 +23,6 @@ CCBool
 CCArray
 CCBatch
 CCOrd
+CCRandom
 CCLinq
 # OASIS_STOP

core/containers.mllib

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: de6b01e36860e123951867ef27ec6b0b)
+# DO NOT EDIT (digest: 8d0afff73fae73db9a0364afaa57d4d2)
 CCVector
 CCDeque
 CCGen
@@ -11,7 +11,7 @@ CCBV
 CCPrint
 CCPersistentHashtbl
 CCError
-CCLeftistheap
+CCHeap
 CCList
 CCOpt
 CCPair
@@ -23,5 +23,6 @@ CCBool
 CCArray
 CCBatch
 CCOrd
+CCRandom
 CCLinq
 # OASIS_STOP

misc/.merlin

@@ -0,0 +1,6 @@
+REC
+S ../core
+S .
+B ../_build/core/
+B ../_build/misc/
+PKG core

misc/printBox.ml

@@ -359,6 +359,25 @@ 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

misc/printBox.mli

@@ -182,6 +182,18 @@ 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

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.4.4 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: fe5bd2b07887db6c08d6cc2023ab6bcd) *)
+(* DO NOT EDIT (digest: e9f5fdc049b9e92ec4196c6ae1642243) *)
 (*
    Regenerated by OASIS v0.4.4
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6774,7 +6774,7 @@ let setup_t =
             CustomPlugin.Test.main
               {
                  CustomPlugin.cmd_main =
-                   [(OASISExpr.EBool true, ("$run_tests", []))];
+                   [(OASISExpr.EBool true, ("make", ["test-all"]))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
               })
@@ -6809,7 +6809,7 @@ let setup_t =
             CustomPlugin.Test.clean
               {
                  CustomPlugin.cmd_main =
-                   [(OASISExpr.EBool true, ("$run_tests", []))];
+                   [(OASISExpr.EBool true, ("make", ["test-all"]))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
               })
@@ -6842,7 +6842,7 @@ let setup_t =
             CustomPlugin.Test.distclean
               {
                  CustomPlugin.cmd_main =
-                   [(OASISExpr.EBool true, ("$run_tests", []))];
+                   [(OASISExpr.EBool true, ("make", ["test-all"]))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
               })
@@ -7006,7 +7006,7 @@ let setup_t =
                            "CCPrint";
                            "CCPersistentHashtbl";
                            "CCError";
-                           "CCLeftistheap";
+                           "CCHeap";
                            "CCList";
                            "CCOpt";
                            "CCPair";
@@ -7018,6 +7018,7 @@ let setup_t =
                            "CCArray";
                            "CCBatch";
                            "CCOrd";
+                           "CCRandom";
                            "CCLinq"
                         ];
                       lib_pack = false;
@@ -7440,6 +7441,40 @@ let setup_t =
                       bs_nativeopt = [(OASISExpr.EBool true, [])]
                    },
                    {exec_custom = false; exec_main_is = "bench_batch.ml"});
+               Executable
+                 ({
+                     cs_name = "bench_hash";
+                     cs_data = PropList.Data.create ();
+                     cs_plugin_data = []
+                  },
+                   {
+                      bs_build =
+                        [
+                           (OASISExpr.EBool true, false);
+                           (OASISExpr.EAnd
+                              (OASISExpr.EFlag "bench",
+                                OASISExpr.EFlag "misc"),
+                             true)
+                        ];
+                      bs_install = [(OASISExpr.EBool true, false)];
+                      bs_path = "tests/";
+                      bs_compiled_object = Native;
+                      bs_build_depends =
+                        [
+                           InternalLibrary "containers";
+                           InternalLibrary "containers_misc"
+                        ];
+                      bs_build_tools = [ExternalTool "ocamlbuild"];
+                      bs_c_sources = [];
+                      bs_data_files = [];
+                      bs_ccopt = [(OASISExpr.EBool true, [])];
+                      bs_cclib = [(OASISExpr.EBool true, [])];
+                      bs_dlllib = [(OASISExpr.EBool true, [])];
+                      bs_dllpath = [(OASISExpr.EBool true, [])];
+                      bs_byteopt = [(OASISExpr.EBool true, [])];
+                      bs_nativeopt = [(OASISExpr.EBool true, [])]
+                   },
+                   {exec_custom = false; exec_main_is = "bench_hash.ml"});
                Executable
                  ({
                      cs_name = "test_levenshtein";
@@ -7586,7 +7621,7 @@ let setup_t =
                    {
                       test_type = (`Test, "custom", Some "0.4");
                       test_command =
-                        [(OASISExpr.EBool true, ("$run_tests", []))];
+                        [(OASISExpr.EBool true, ("make", ["test-all"]))];
                       test_custom =
                         {
                            pre_command = [(OASISExpr.EBool true, None)];
@@ -7699,7 +7734,7 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.4";
-     oasis_digest = Some "\nX\138\218t6.\019\019&&J\236o\130\237";
+     oasis_digest = Some "\017\130L\20257\216\2367yE\018q\163z<";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
@@ -7707,6 +7742,6 @@ let setup_t =
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7711 "setup.ml"
+# 7746 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

tests/.merlin

@@ -0,0 +1,3 @@
+S .
+B ../_build/tests/
+REC

tests/bench_hash.ml

@@ -0,0 +1,84 @@
+(** Test hash functions *)
+
+type tree =
+  | Empty
+  | Node of int * tree list
+
+let mk_node i l = Node (i,l)
+
+let random_tree =
+  CCRandom.(fix
+    ~base:(return Empty)
+    ~subn:[int 10, (fun sublist -> pure mk_node <*> small_int <*> sublist)]
+    (int_range 15 150)
+  )
+
+let random_list =
+  CCRandom.(
+    int 5 >>= fun len ->
+    CCList.random_len len random_tree
+  )
+
+let rec eq t1 t2 = match t1, t2 with
+  | Empty, Empty -> true
+  | Node(i1,l1), Node (i2,l2) -> i1=i2 && CCList.equal eq l1 l2
+  | Node _, _
+  | _, Node _ -> false
+
+let rec hash_tree t h = match t with
+  | Empty -> CCHash.string_ "empty" h
+  | Node (i, l) ->
+      h |> CCHash.string_ "node" |> CCHash.int_ i |> CCHash.list_ hash_tree l
+
+module Box = Containers_misc.PrintBox
+
+let tree2box = Box.mk_tree
+  (function
+    | Empty -> Box.empty, []
+    | Node (i,l) -> Box.line (CCPrint.sprintf "node %d" i), l
+  )
+
+let l = CCRandom.(run (CCList.random random_list))
+
+let pp_list buf l =
+  let box = Box.(frame (vlist ~bars:true (List.map tree2box l))) in
+  CCPrint.string buf (Box.to_string box)
+
+(* print some terms *)
+let () =
+  List.iter
+    (fun l -> CCPrint.printf "%a\n" pp_list l) l
+
+
+module H = Hashtbl.Make(struct
+  type t = tree
+  let equal = eq
+  let hash = CCHash.apply hash_tree
+end)
+
+let print_hashcons_stats st =
+  let open Hashtbl in
+    CCPrint.printf
+      "tbl stats: %d elements, num buckets: %d, max bucket: %d\n"
+      st.num_bindings st.num_buckets st.max_bucket_length;
+    Array.iteri
+      (fun i n -> CCPrint.printf "  %d\t buckets have length %d\n" n i)
+      st.bucket_histogram
+
+let () =
+  let st = Random.State.make_self_init () in
+  let n = 50_000 in
+  CCPrint.printf "generate %d elements...\n" n;
+  let l = CCRandom.run ~st (CCList.random_len n random_tree) in
+  (* with custom hashtable *)
+  CCPrint.printf "### custom hashtable\n";
+  let tbl = H.create 256 in
+  List.iter (fun t -> H.replace tbl t ()) l;
+  print_hashcons_stats (H.stats tbl);
+  (* with default hashtable *)
+  CCPrint.printf "### default hashtable\n";
+  let tbl' = Hashtbl.create 256 in
+  List.iter (fun t -> Hashtbl.replace tbl' t ()) l;
+  print_hashcons_stats (Hashtbl.stats tbl');
+  ()
+

tests/run_tests.ml

@@ -11,7 +11,7 @@ let suite =
       Test_PiCalculus.suite;
       Test_splayMap.suite;
       Test_bij.suite;
-      Test_leftistheap.suite;
+      Test_CCHeap.suite;
       Test_cc.suite;
       Test_puf.suite;
       Test_vector.suite;

tests/test_CCHeap.ml

@@ -3,26 +3,27 @@
 
 open OUnit
 
-module Leftistheap = CCLeftistheap
 module Sequence = CCSequence
 
-let empty = Leftistheap.empty
+module H = CCHeap.Make(struct type t = int let leq x y =x<=y end)
+
+let empty = H.empty
 
 let test1 () =
-  let h = Leftistheap.of_seq empty (Sequence.of_list [5;3;4;1;42;0]) in
+  let h = H.of_list [5;3;4;1;42;0] in
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 0 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 1 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 3 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 4 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 5 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 42 x;
-  OUnit.assert_raises Not_found (fun () -> Leftistheap.extract_min h);
+  OUnit.assert_raises H.Empty (fun () -> H.take_exn h);
   ()
 
 let rec is_sorted l = match l with
@@ -33,10 +34,10 @@ let rec is_sorted l = match l with
 (* extract the content of the heap into a list *)
 let extract_list heap =
   let rec recurse acc h =
-    if Leftistheap.is_empty h
+    if H.is_empty h
       then List.rev acc
       else
-        let h', x = Leftistheap.extract_min h in
+        let h', x = H.take_exn h in
         recurse (x::acc) h'
   in
   recurse [] heap
@@ -46,8 +47,8 @@ let test_sort () =
   let n = 100_000 in
   let l = Sequence.to_rev_list (Sequence.take n (Sequence.random_int n)) in
   (* put elements into a heap *)
-  let h = Leftistheap.of_seq empty (Sequence.of_list l) in
+  let h = H.of_seq empty (Sequence.of_list l) in
-  OUnit.assert_equal n (Leftistheap.size h);
+  OUnit.assert_equal n (H.size h);
   let l' = extract_list h in
   OUnit.assert_bool "sorted" (is_sorted l');
   ()

tests/test_fQueue.ml

@@ -8,20 +8,22 @@ let test_empty () =
   let q = FQueue.empty in
   OUnit.assert_bool "is_empty" (FQueue.is_empty q)
 
+let pp_ilist = CCPrint.(to_string (list int))
+
 let test_push () =
-  let q = List.fold_left FQueue.push FQueue.empty [1;2;3;4;5] in
+  let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in
-  let q = FQueue.junk q in
+  let q = FQueue.tail q in
-  let q = List.fold_left FQueue.push q [6;7;8] in
+  let q = List.fold_left FQueue.snoc q [6;7;8] in
   let l = Sequence.to_list (FQueue.to_seq q) in
-  OUnit.assert_equal [2;3;4;5;6;7;8] l
+  OUnit.assert_equal ~printer:pp_ilist [2;3;4;5;6;7;8] l
 
 let test_pop () =
-  let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in
+  let q = FQueue.of_list [1;2;3;4] in
-  let x, q = FQueue.pop q in
+  let x, q = FQueue.take_front_exn q in
   OUnit.assert_equal 1 x;
-  let q = List.fold_left FQueue.push q [5;6;7] in
+  let q = List.fold_left FQueue.snoc q [5;6;7] in
-  OUnit.assert_equal 2 (FQueue.peek q);
+  OUnit.assert_equal 2 (FQueue.first_exn q);
-  let x, q = FQueue.pop q in
+  let x, q = FQueue.take_front_exn q in
   OUnit.assert_equal 2 x;
   ()
 
@@ -30,7 +32,7 @@ let test_append () =
   let q2 = FQueue.of_seq (Sequence.of_list [5;6;7;8]) in 
   let q = FQueue.append q1 q2 in
   let l = Sequence.to_list (FQueue.to_seq q) in
-  OUnit.assert_equal [1;2;3;4;5;6;7;8] l
+  OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5;6;7;8] l
 
 let test_fold () =
   let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in
@@ -39,7 +41,7 @@ let test_fold () =
   ()
 
 let suite =
-  "test_pQueue" >:::
+  "test_FQueue" >:::
     [ "test_empty" >:: test_empty;
       "test_push" >:: test_push;
       "test_pop" >:: test_pop;