diff --git a/.merlin b/.merlin index 7598e01b..8d5ebfe5 100644 --- a/.merlin +++ b/.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 diff --git a/Makefile b/Makefile index d2e1bbb3..6d920d9b 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README.md b/README.md index 4aac41da..640a8177 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/_oasis b/_oasis index e4567f67..627456dc 100644 --- a/_oasis +++ b/_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, - 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) diff --git a/_tags b/_tags index 29ba6791..c0acdf36 100644 --- a/_tags +++ b/_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 : package(bench) -: package(unix) -: use_containers_misc : 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 : package(benchmark) +# Executable bench_hash +"tests/bench_hash.native": package(unix) +"tests/bench_hash.native": use_containers +"tests/bench_hash.native": use_containers_misc +: package(unix) +: use_containers_misc # Executable test_levenshtein "tests/test_levenshtein.native": package(qcheck) "tests/test_levenshtein.native": use_containers diff --git a/containers.odocl b/containers.odocl index 0ce2cd87..9a575742 100644 --- a/containers.odocl +++ b/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 diff --git a/core/CCArray.ml b/core/CCArray.ml index 7de43cfe..4ddbe08f 100644 --- a/core/CCArray.ml +++ b/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 diff --git a/core/CCArray.mli b/core/CCArray.mli index a961bd38..41637ed5 100644 --- a/core/CCArray.mli +++ b/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. @@ -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 *) diff --git a/core/CCBV.ml b/core/CCBV.ml index 34f9a99a..37eeebb2 100644 --- a/core/CCBV.ml +++ b/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,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 +*) + diff --git a/core/CCBV.mli b/core/CCBV.mli index c32701bc..f3ffd3bb 100644 --- a/core/CCBV.mli +++ b/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 diff --git a/core/CCBool.ml b/core/CCBool.ml index 3db3dbc0..b890edeb 100644 --- a/core/CCBool.ml +++ b/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 diff --git a/core/CCBool.mli b/core/CCBool.mli index 0ea1131c..e0cc63bc 100644 --- a/core/CCBool.mli +++ b/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 diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 1e76711b..80aea967 100644 --- a/core/CCFQueue.ml +++ b/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 = - 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) diff --git a/core/CCFQueue.mli b/core/CCFQueue.mli index 84fbd068..d78481fa 100644 --- a/core/CCFQueue.mli +++ b/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 - (** 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 + diff --git a/core/CCHash.ml b/core/CCHash.ml index e485d228..17a53675 100644 --- a/core/CCHash.ml +++ b/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 = - (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) diff --git a/core/CCHash.mli b/core/CCHash.mli index e250ed10..576e594b 100644 --- a/core/CCHash.mli +++ b/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 -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 diff --git a/core/CCHeap.ml b/core/CCHeap.ml new file mode 100644 index 00000000..698ca2cf --- /dev/null +++ b/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 diff --git a/core/CCLeftistheap.mli b/core/CCHeap.mli similarity index 58% rename from core/CCLeftistheap.mli rename to core/CCHeap.mli index 9836ce9a..e265aef4 100644 --- a/core/CCLeftistheap.mli +++ b/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} -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 diff --git a/core/CCInt.ml b/core/CCInt.ml index 478e105a..a5689aa5 100644 --- a/core/CCInt.ml +++ b/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" diff --git a/core/CCInt.mli b/core/CCInt.mli index 11b7abc7..e62291a1 100644 --- a/core/CCInt.mli +++ b/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 diff --git a/core/CCKList.ml b/core/CCKList.ml index d9a1112e..9dd606e6 100644 --- a/core/CCKList.ml +++ b/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 = diff --git a/core/CCKList.mli b/core/CCKList.mli index ddb808bb..0997a7f2 100644 --- a/core/CCKList.mli +++ b/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 diff --git a/core/CCLeftistheap.ml b/core/CCLeftistheap.ml deleted file mode 100644 index 1a73853c..00000000 --- a/core/CCLeftistheap.ml +++ /dev/null @@ -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 diff --git a/core/CCList.ml b/core/CCList.ml index 6a748d52..7375f5d8 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -378,11 +378,22 @@ let range i j = range 5 2 = [5;4;3;2] *) +let range' i j = + if i 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 = diff --git a/core/CCList.mli b/core/CCList.mli index eafd9656..f835ef4c 100644 --- a/core/CCList.mli +++ b/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 diff --git a/core/CCOpt.ml b/core/CCOpt.ml index 3c8f0b50..85870d80 100644 --- a/core/CCOpt.ml +++ b/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 diff --git a/core/CCOpt.mli b/core/CCOpt.mli index 7c6e4b6d..2f94549d 100644 --- a/core/CCOpt.mli +++ b/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 diff --git a/core/CCRandom.ml b/core/CCRandom.ml new file mode 100644 index 00000000..86b1e6db --- /dev/null +++ b/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 + diff --git a/core/CCRandom.mli b/core/CCRandom.mli new file mode 100644 index 00000000..fcf00d42 --- /dev/null +++ b/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 *) + diff --git a/core/CCSequence.mli b/core/CCSequence.mli index 9ac6c616..b6e1a4a4 100644 --- a/core/CCSequence.mli +++ b/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 - 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 diff --git a/core/_tags b/core/_tags new file mode 100644 index 00000000..1ebb483c --- /dev/null +++ b/core/_tags @@ -0,0 +1 @@ +: inline(20) diff --git a/core/containers.mldylib b/core/containers.mldylib index dc6385a8..c5000e1f 100644 --- a/core/containers.mldylib +++ b/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 diff --git a/core/containers.mllib b/core/containers.mllib index dc6385a8..c5000e1f 100644 --- a/core/containers.mllib +++ b/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 diff --git a/misc/.merlin b/misc/.merlin new file mode 100644 index 00000000..cc64b0c4 --- /dev/null +++ b/misc/.merlin @@ -0,0 +1,6 @@ +REC +S ../core +S . +B ../_build/core/ +B ../_build/misc/ +PKG core diff --git a/misc/printBox.ml b/misc/printBox.ml index de703a11..4abada71 100644 --- a/misc/printBox.ml +++ b/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 diff --git a/misc/printBox.mli b/misc/printBox.mli index a22e4320..e769915a 100644 --- a/misc/printBox.mli +++ b/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 diff --git a/setup.ml b/setup.ml index 420cb70b..580016c7 100644 --- a/setup.ml +++ b/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 ();; diff --git a/tests/.merlin b/tests/.merlin new file mode 100644 index 00000000..c8fb82a3 --- /dev/null +++ b/tests/.merlin @@ -0,0 +1,3 @@ +S . +B ../_build/tests/ +REC diff --git a/tests/bench_hash.ml b/tests/bench_hash.ml new file mode 100644 index 00000000..c17f3969 --- /dev/null +++ b/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'); + () + diff --git a/tests/run_tests.ml b/tests/run_tests.ml index a1b8893d..858df690 100644 --- a/tests/run_tests.ml +++ b/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; diff --git a/tests/test_leftistheap.ml b/tests/test_CCHeap.ml similarity index 62% rename from tests/test_leftistheap.ml rename to tests/test_CCHeap.ml index 2204ca8c..a0c97a79 100644 --- a/tests/test_leftistheap.ml +++ b/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, 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'); () diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml index a4c5c48a..33082e5e 100644 --- a/tests/test_fQueue.ml +++ b/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 = 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;