simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2026-01-23 09:36:41 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

merge from dev

Browse source
This commit is contained in:
Simon Cruanes 2014-06-25 01:47:51 +02:00
commit 4adcf95b4d
42 changed files with 1560 additions and 400 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.merlin
View file

@ -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

12
Makefile
View file

@ -62,13 +62,15 @@ 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
@echo
qtest: qtest-build
@echo
./qtest_all.native
push-stable: all
@ -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

28
README.md
View file

@ -49,18 +49,28 @@ structures comprise (some modules in `misc/`, some other in `core/`):
### Core Structures
- `CCLeftistheap`, a polymorphic heap structure.
- `CCFQueue`, a purely functional queue structure
- `CCHeap`, a purely functional heap 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
- `CCList`, functions and lists including tail-recursive implementations of `map` and `append`
- `CCArray`, utilities on arrays
- `CCInt`, `CCPair`, `CCOpt`, `CCFun`, `CCBool`, utilities on basic types
- `CCPrint`, printing combinators
- `CCHash`, hashing combinators
- `CCKlist`, a persistent iterator structure (akin to a lazy list)
- `CCList`, functions and lists including tail-recursive implementations of `map` and `append` and many other utilities
- `CCArray`, utilities on arrays and slices
- `CCLinq`, high-level query language over collections
- `CCMultimap` and `CCMultiset`, functors defining persistent structures
- 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

15
_oasis
View file

@ -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,
CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCLinq
CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash,
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)

10
_tags
View file

@ -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

5
containers.odocl
View file

@ -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

24
core/CCArray.ml
View file

@ -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

11
core/CCArray.mli
View file

@ -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.
@ -155,7 +164,7 @@ module Sub : sig
val underlying : 'a t -> 'a array
(** Underlying array (shared). Modifying this array will modify the slice *)
val copy : 'a t -> 'a array
(** Copy into a new array *)

80
core/CCBV.ml
View file

@ -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,9 +204,18 @@ 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)
(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
@ -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
*)

9
core/CCBV.mli
View file

@ -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

2
core/CCBool.ml
View file

@ -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

2
core/CCBool.mli
View file

@ -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

335
core/CCFQueue.ml
View file

@ -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 =
let q = ref empty in
seq (fun x -> q := push !q x);
type 'a digit =
| Zero
| 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)

94
core/CCFQueue.mli
View file

@ -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
(** Push element at the end of the queue *)
exception Empty
val peek : 'a t -> 'a
(** Get first element, or raise Invalid_argument *)
val cons : 'a -> 'a t -> 'a t
(** Push element at the front of the queue *)
val pop : 'a t -> 'a * 'a t
(** Get and remove the first element, or raise Invalid_argument *)
val snoc : 'a t -> 'a -> 'a t
(** Push element at the end of the queue *)
val junk : 'a t -> 'a t
(** Remove first element. If queue is empty, do nothing. *)
val take_front : 'a t -> ('a * 'a t) option
(** 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

82
core/CCHash.ml
View file

@ -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 =
(hash * 65599 + i) land max_int
let _r = 47
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 =
combine (combine (combine i j) k) l
(** {2 Combinators} *)
let rec hash_list f h l = match l with
| [] -> h
| x::l' -> hash_list f (combine h (f x)) l'
let int_ i s = _combine s (Int64.of_int i)
let bool_ x s = _combine s (if x then 1L else 2L)
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 h = ref h in
Array.iter (fun x -> h := combine !h (f x)) a;
!h
let rec list_ f l s = match l with
| [] -> s
| x::l' -> list_ f l' (f x s)
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 hash_triple h1 h2 h3 (x,y,z) = (h1 x) <<>> (h2 y) <<>> (h3 z)
let opt f o h = match o with
| 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 h = ref h in
seq (fun x -> h := !h <<>> f x);
!h
let seq f seq s =
let s = ref s in
seq (fun x -> s := f x !s);
!s
let rec hash_gen f h g = match g () with
| None -> h
| Some x ->
hash_gen f (h <<>> f x) g
let rec gen f g s = match g () with
| None -> s
| Some x -> gen f g (f x s)
let rec hash_klist f h l = match l () with
| `Nil -> h
| `Cons (x,l') -> hash_klist f (h <<>> f x) l'
let rec klist f l s = match l () with
| `Nil -> s
| `Cons (x,l') -> klist f l' (f x s)

57
core/CCHash.mli
View file

@ -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
SDBM simple hash (see for instance
{{:http://www.cse.yorku.ca/~oz/hash.html} this page})
Combination of hashes based on the Murmur Hash (64 bits). See
{{: https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} 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
(** Combine two hashes. Non-commutative. *)
type 'a hash_fun = 'a -> state -> state
(** Hash function for values of type ['a], merging a fingerprint of the
value into the state of type [t] *)
val (<<>>) : t -> t -> t
(** Infix version of {!combine} *)
val init : state
(** Initial value *)
val hash_int : int -> t
val hash_int2 : int -> int -> t
val hash_int3 : int -> int -> int -> t
val hash_int4 : int -> int -> int -> int -> t
val finish : state -> int
(** Extract a usable hash value *)
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 hash_triple : 'a hash_fun -> 'b hash_fun -> 'c hash_fun -> ('a * 'b * 'c) hash_fun
val opt : 'a hash_fun -> 'a option 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 hash_gen : 'a hash_fun -> t -> 'a gen hash_fun
val hash_klist : 'a hash_fun -> t -> 'a klist hash_fun
val seq : 'a hash_fun -> 'a sequence hash_fun
val gen : 'a hash_fun -> 'a gen hash_fun
val klist : 'a hash_fun -> 'a klist hash_fun

240
core/CCHeap.ml Normal file
View file

@ -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

82
core/CCLeftistheap.mli → core/CCHeap.mli
View file

@ -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}
Polymorphic implementation, following Okasaki *)
(** {1 Leftist Heaps} 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
(** Heap containing values of type 'a *)
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
val empty_with : leq:('a -> 'a -> bool) -> 'a t
(** Empty heap. The function is used to check whether the first element is
smaller than the second. *)
module type S = sig
type elt
type t
val empty : 'a t
(** Empty heap using [Pervasives.compare] *)
val empty : t
(** Empty heap *)
val is_empty : _ t -> bool
val is_empty : t -> bool
(** Is the heap empty? *)
val merge : 'a t -> 'a t -> 'a t
(** Merge two heaps (assume they have the same comparison function) *)
exception Empty
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
(** Find minimal element, or fails
@raise Not_found if the heap is empty *)
val find_min : t -> elt option
(** Find minimal element *)
val extract_min : 'a t -> 'a t * 'a
(** Extract and returns the minimal element, or
raise Not_found if the heap is empty *)
val find_min_exn : t -> elt
(** Same as {!find_min} but can fail
@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
val to_seq : 'a t -> 'a sequence
(** {2 Conversions} *)
val of_klist : 'a t -> 'a klist -> 'a t
val to_klist : 'a t -> 'a klist
val to_list : t -> elt list
val of_list : elt list -> t
val of_gen : 'a t -> 'a gen -> 'a t
val to_gen : 'a t -> 'a gen
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) : S with type elt = E.t

5
core/CCInt.ml
View file

@ -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"

5
core/CCInt.mli
View file

@ -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

27
core/CCKList.ml
View file

@ -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 =

15
core/CCKList.mli
View file

@ -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

180
core/CCLeftistheap.ml
View file

@ -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

69
core/CCList.ml
View file

@ -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 =
@ -474,7 +485,7 @@ module Zipper = struct
| None -> l,r
| Some x' -> l, x::r
end
let focused = function
| _, x::_ -> Some x
| _, [] -> None
@ -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 =

32
core/CCList.mli
View file

@ -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

4
core/CCOpt.ml
View file

@ -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

3
core/CCOpt.mli
View file

@ -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

169
core/CCRandom.ml Normal file
View file

@ -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

116
core/CCRandom.mli Normal file
View file

@ -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 *)

4
core/CCSequence.mli
View file

@ -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
values of type ['a]. *)
(** Sequence iterator type, representing a finite sequence of values
of type ['a] that one can iterate on. *)
type +'a sequence = 'a t

1
core/_tags Normal file
View file

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

5
core/containers.mldylib
View file

@ -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

5
core/containers.mllib
View file

@ -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

6
misc/.merlin Normal file
View file

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

19
misc/printBox.ml
View file

@ -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

12
misc/printBox.mli
View file

@ -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

51
setup.ml
View file

@ -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 ();;

3
tests/.merlin Normal file
View file

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

84
tests/bench_hash.ml Normal file
View file

@ -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');
()

2
tests/run_tests.ml
View file

@ -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;

29
tests/test_leftistheap.ml → tests/test_CCHeap.ml
View file

@ -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, x = Leftistheap.extract_min h in
let h = H.of_list [5;3;4;1;42;0] 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
OUnit.assert_equal n (Leftistheap.size h);
let h = H.of_seq empty (Sequence.of_list l) in
OUnit.assert_equal n (H.size h);
let l' = extract_list h in
OUnit.assert_bool "sorted" (is_sorted l');
()

24
tests/test_fQueue.ml
View file

@ -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 = FQueue.junk q in
let q = List.fold_left FQueue.push q [6;7;8] in
let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in
let q = FQueue.tail q 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 x, q = FQueue.pop q in
let q = FQueue.of_list [1;2;3;4] 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
OUnit.assert_equal 2 (FQueue.peek q);
let x, q = FQueue.pop q in
let q = List.fold_left FQueue.snoc q [5;6;7] in
OUnit.assert_equal 2 (FQueue.first_exn q);
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;