From fcd2085190b9ae2ed5e920eb3b1d5c60446c7117 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 23 Jun 2014 23:01:01 +0200 Subject: [PATCH 01/15] CCHash now uses murmur hash --- core/CCHash.ml | 77 +++++++++++++++++++++++++++++-------------------- core/CCHash.mli | 51 ++++++++++++++++++-------------- 2 files changed, 76 insertions(+), 52 deletions(-) diff --git a/core/CCHash.ml b/core/CCHash.ml index e485d228..6edbe8c1 100644 --- a/core/CCHash.ml +++ b/core/CCHash.ml @@ -25,51 +25,66 @@ 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 t = int64 +type 'a hash_fun = 'a -> t -> t -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 Combinateurs} *) -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 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)) 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..33c56263 100644 --- a/core/CCHash.mli +++ b/core/CCHash.mli @@ -25,40 +25,49 @@ 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} *) -type t = int +(** {2 Definitions} *) -type 'a hash_fun = 'a -> t +type t = private int64 -val combine : t -> t -> t - (** Combine two hashes. Non-commutative. *) +type 'a hash_fun = 'a -> t -> t +(** 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 : t +(** 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 : t -> 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 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 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 From 1beab5268bfdc09ac622cf2316db060d5794f830 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 23 Jun 2014 23:29:47 +0200 Subject: [PATCH 02/15] changed comments, add _tags file --- core/CCHash.ml | 2 +- core/CCSequence.mli | 4 ++-- core/_tags | 1 + 3 files changed, 4 insertions(+), 3 deletions(-) create mode 100644 core/_tags diff --git a/core/CCHash.ml b/core/CCHash.ml index 6edbe8c1..5c6b3885 100644 --- a/core/CCHash.ml +++ b/core/CCHash.ml @@ -50,7 +50,7 @@ let finish s = let apply f x = finish (f x init) -(** {2 Combinateurs} *) +(** {2 Combinators} *) let int_ i s = _combine s (Int64.of_int i) let bool_ x s = _combine s (if x then 1L else 2L) 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) From b56cdfa17a4544194e30796208dc5e5e884578c2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 23 Jun 2014 23:40:10 +0200 Subject: [PATCH 03/15] more hash functions --- core/CCHash.ml | 6 ++++++ core/CCHash.mli | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/core/CCHash.ml b/core/CCHash.ml index 5c6b3885..9432b588 100644 --- a/core/CCHash.ml +++ b/core/CCHash.ml @@ -69,9 +69,15 @@ let rec list_ f l s = match l with let array_ f a s = Array.fold_right f a s +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] diff --git a/core/CCHash.mli b/core/CCHash.mli index 33c56263..279c21f2 100644 --- a/core/CCHash.mli +++ b/core/CCHash.mli @@ -61,9 +61,13 @@ val list_ : 'a hash_fun -> 'a list hash_fun val array_ : 'a hash_fun -> 'a array 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] From 6872591708a13ef32a40b1e3935c51d89fedb716 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 23 Jun 2014 23:44:53 +0200 Subject: [PATCH 04/15] make a distinction between Hash.state and Hash.t (and private type is bad here) --- core/CCHash.ml | 5 +++-- core/CCHash.mli | 12 ++++++++---- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/core/CCHash.ml b/core/CCHash.ml index 9432b588..17a53675 100644 --- a/core/CCHash.ml +++ b/core/CCHash.ml @@ -25,8 +25,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash combinators} *) -type t = int64 -type 'a hash_fun = 'a -> t -> t +type t = int +type state = int64 +type 'a hash_fun = 'a -> state -> state let _r = 47 let _m = 0xc6a4a7935bd1e995L diff --git a/core/CCHash.mli b/core/CCHash.mli index 279c21f2..a5c61102 100644 --- a/core/CCHash.mli +++ b/core/CCHash.mli @@ -31,16 +31,20 @@ Combination of hashes based on the Murmur Hash (64 bits). See (** {2 Definitions} *) -type t = private int64 +type t = int +(** A hash value is a positive integer *) -type 'a hash_fun = 'a -> t -> t +type state = int64 +(** State required by the hash function *) + +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 init : t +val init : state (** Initial value *) -val finish : t -> int +val finish : state -> int (** Extract a usable hash value *) val apply : 'a hash_fun -> 'a -> int From 9da54f3e5a084dd6b650beab2e60dcb82c400bf1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 14:06:48 +0200 Subject: [PATCH 05/15] random generators in several modules, and CCRandom to bind them all with fuel --- _oasis | 3 +- core/CCArray.ml | 24 ++++++++ core/CCArray.mli | 11 +++- core/CCHash.mli | 2 +- core/CCInt.ml | 5 ++ core/CCInt.mli | 5 ++ core/CCList.ml | 39 +++++++++++- core/CCList.mli | 15 ++++- core/CCOpt.ml | 4 ++ core/CCOpt.mli | 3 + core/CCRandom.ml | 152 ++++++++++++++++++++++++++++++++++++++++++++++ core/CCRandom.mli | 142 +++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 399 insertions(+), 6 deletions(-) create mode 100644 core/CCRandom.ml create mode 100644 core/CCRandom.mli diff --git a/_oasis b/_oasis index e4567f67..d32eef86 100644 --- a/_oasis +++ b/_oasis @@ -41,7 +41,8 @@ Library "containers" 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 + CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, + CCRandom, CCLinq FindlibName: containers Library "containers_string" 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/CCHash.mli b/core/CCHash.mli index a5c61102..576e594b 100644 --- a/core/CCHash.mli +++ b/core/CCHash.mli @@ -26,7 +26,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Hash combinators} Combination of hashes based on the Murmur Hash (64 bits). See -{{:https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} this page} +{{: https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} this page} *) (** {2 Definitions} *) 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/CCList.ml b/core/CCList.ml index 6a748d52..4da93f76 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 @@ -491,6 +502,30 @@ 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 to_seq l k = List.iter k l let of_seq seq = diff --git a/core/CCList.mli b/core/CCList.mli index eafd9656..051446fd 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] *) @@ -223,6 +227,15 @@ 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 list random_gen +val random_non_empty : 'a random_gen -> 'a list random_gen +val random_len : int -> 'a random_gen -> 'a list random_gen + +val random_choose : 'a list -> 'a random_gen +(** Randomly choose an element in the list. + @raise Not_found if the list is empty *) 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..9385542e --- /dev/null +++ b/core/CCRandom.ml @@ -0,0 +1,152 @@ + +(* +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)) st + +let choose l = choose_array (Array.of_list l) + +let choose_return l = choose_array (Array.of_list (List.map return l)) + +(** {2 Fuel and Backtracking} *) + +module Fuel = struct + type fuel = int + + exception Backtrack + + (* consume [d] units of fuel and return [x] if it works *) + let _consume d fuel x = + if fuel >= d then Some (fuel-d,x) else None + + let _split i st = + if i < 2 then raise Backtrack + else + let j = 1 + Random.State.int st (i-1) in + (j, i-j) + + let split i st = try Some (_split i st) with Backtrack -> 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 Backtrack + else if len = 1 then i::acc + else + (* split somewhere in the middle *) + let len1, len2 = _split len st in + if i = len + then aux len1 ~len:len1 (aux len2 ~len:len2 acc) + else + let i1, i2 = _split (i-len1-len2) st in + aux i1 ~len:len1 (aux i2 ~len:len2 acc) + in + try Some (aux i ~len []) with Backtrack -> None + + (** {6 Fueled Generators} *) + + type 'a t = fuel -> state -> (fuel * 'a) option + + let return x fuel _st = _consume 1 fuel x + + let return' fuel x fuel' _st = _consume fuel fuel' x + + let flat_map f g fuel st = + match g fuel st with + | None -> None + | Some (fuel, x) -> f x fuel st + + let (>>=) g f = flat_map f g + + let map f g fuel st = + match g fuel st with + | None -> None + | Some (fuel, x) -> Some (fuel, f x) + + let (>|=) g f = map f g + + let consume fuel _st = _consume 1 fuel () + + let consume' fuel fuel' _st = _consume fuel fuel' () + + let fail _fuel _st = None + + let retry ?(max=10) g fuel st = + let rec aux n = + match g fuel st with + | None when n=0 -> None + | None -> aux (n-1) (* retry *) + | Some _ as res -> res + in + aux max + + let rec try_successively l fuel st = match l with + | [] -> None + | g :: l' -> + begin match g fuel st with + | None -> try_successively l' fuel st + | Some _ as res -> res + end + + let () a b = try_successively [a;b] + + let rec fix f fuel st = f (fix f) fuel st + + let lift g fuel st = _consume 1 fuel (g st) + + let lift' d g fuel st = _consume d fuel (g st) + + let run ?(fuel=fun st -> Random.State.int st 40) f st = + match f (fuel st) st with + | None -> None + | Some (_fuel, x) -> Some x + + exception GenFailure + + let run_exn ?fuel f st = + match run ?fuel f st with + | None -> raise GenFailure + | Some x -> x +end diff --git a/core/CCRandom.mli b/core/CCRandom.mli new file mode 100644 index 00000000..22b48ca5 --- /dev/null +++ b/core/CCRandom.mli @@ -0,0 +1,142 @@ + +(* +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 t +(** Choose a generator within the list. + @raise Invalid_argument if the list is empty *) + +val choose_array : 'a t array -> 'a t + +val choose_return : 'a list -> 'a t +(** Choose among the list + @raise Invalid_argument if the list is empty *) + +(** {2 Fuel and Backtracking} *) + +module Fuel : sig + type fuel = int + (** The fuel is a value that represents some "resource" used by the + random generator. *) + + val split : fuel -> (fuel * fuel) option t + (** Split a (fuel) value [n] into [n1,n2] where [n = n1 + n2]. + @return [None] if the value is too small *) + + val split_list : fuel -> len:int -> fuel list option t + (** Split a (fuel) value [n] into a list of values whose sum is [n] + and whose length is [length]. + @return [None] if the value is too small *) + + (** {6 Fueled Generators} *) + + type 'a t = fuel -> state -> (fuel * 'a) option + (** Fueled generators use some fuel to generate a value. + Can fail by lack of fuel. *) + + val return : 'a -> 'a t + (** [return x] is the generator that always returns [x], and consumes one + fuel doing it. *) + + val return' : fuel -> 'a -> 'a t + (** [return' f x] returns [x] but also consumes [fuel]. *) + + 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 consume : unit t + (** Consume one fuel value *) + + val consume' : fuel -> unit t + (** Consume the given amount of fuel *) + + val fail : 'a t + (** Always fails. *) + + val retry : ?max:int -> 'a t -> 'a 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 t list -> 'a 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 t -> 'a t -> 'a 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 : ('a t -> 'a t) -> 'a t + (** Recursion combinators, for building (fueled) recursive values *) + + val lift : 'a random_gen -> 'a t + (** lifts a regular random generator into a fueled one, that consumes + one fuel unit *) + + val lift' : fuel -> 'a random_gen -> 'a t + (** lifts a regular random generator into a fueled one, that consumes + one fuel unit *) + + (** {6 Running} *) + + val run : ?fuel:fuel random_gen -> 'a t -> 'a option random_gen + (** Run the given fueled generator with an amount of fuel + given by the [fuel] generator. + @return None if the *) + + exception GenFailure + + val run_exn : ?fuel:fuel random_gen -> 'a t -> 'a random_gen + (** Same as {!run}, but in case of failure it raises an exception. + @raise GenFailure in case the generator fails *) +end From e5a842829ea153636dd0b234a35beda1ad291dee Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 16:23:30 +0200 Subject: [PATCH 06/15] monadic combinators for lists and klists --- core/CCKList.ml | 27 +++++++++++++++++++++++++++ core/CCKList.mli | 15 +++++++++++++++ core/CCList.ml | 30 ++++++++++++++++++++++++++++++ core/CCList.mli | 25 +++++++++++++++++++++---- 4 files changed, 93 insertions(+), 4 deletions(-) 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/CCList.ml b/core/CCList.ml index 4da93f76..7375f5d8 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -495,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 @@ -527,6 +555,8 @@ let random_choose l = match l with 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 = let l = ref [] in diff --git a/core/CCList.mli b/core/CCList.mli index 051446fd..f835ef4c 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -220,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 @@ -229,14 +244,16 @@ 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 list random_gen -val random_non_empty : 'a random_gen -> 'a list random_gen -val random_len : int -> 'a random_gen -> 'a list random_gen +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 list -> 'a 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 From 2b15a21570c859376f0c176d175c3d08310ba1d1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 16:24:19 +0200 Subject: [PATCH 07/15] refactored CCrandom (hide fuel, too complicated, but provide a fix operator); bench_hash to compare hash combinators to the default hash function --- .merlin | 2 +- _oasis | 8 ++ core/CCRandom.ml | 191 ++++++++++++++++++++++++-------------------- core/CCRandom.mli | 120 +++++++++++----------------- misc/.merlin | 6 ++ tests/.merlin | 3 + tests/bench_hash.ml | 84 +++++++++++++++++++ 7 files changed, 253 insertions(+), 161 deletions(-) create mode 100644 misc/.merlin create mode 100644 tests/.merlin create mode 100644 tests/bench_hash.ml 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/_oasis b/_oasis index d32eef86..bc8324f0 100644 --- a/_oasis +++ b/_oasis @@ -146,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 diff --git a/core/CCRandom.ml b/core/CCRandom.ml index 9385542e..86b1e6db 100644 --- a/core/CCRandom.ml +++ b/core/CCRandom.ml @@ -41,112 +41,129 @@ let map f g st = f (g st) let (>|=) g f st = map f g st -let choose_array a 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)) st + a.(Random.State.int st (Array.length a)) -let choose l = choose_array (Array.of_list l) +let choose_array a st = + try Some (_choose_array a st st) with Invalid_argument _ -> None -let choose_return l = choose_array (Array.of_list (List.map return l)) +let choose l = + let a = Array.of_list l in + choose_array a -(** {2 Fuel and Backtracking} *) +let choose_exn l = + let a = Array.of_list l in + fun st -> _choose_array a st st -module Fuel = struct - type fuel = int +let choose_return l = _choose_array (Array.of_list l) - exception Backtrack +let int i st = Random.State.int st i - (* consume [d] units of fuel and return [x] if it works *) - let _consume d fuel x = - if fuel >= d then Some (fuel-d,x) else None +let small_int = int 100 - let _split i st = - if i < 2 then raise Backtrack +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 - let j = 1 + Random.State.int st (i-1) in - (j, i-j) - - let split i st = try Some (_split i st) with Backtrack -> 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 Backtrack - else if len = 1 then i::acc + (* 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 - (* split somewhere in the middle *) - let len1, len2 = _split len st in - if i = len - then aux len1 ~len:len1 (aux len2 ~len:len2 acc) - else - let i1, i2 = _split (i-len1-len2) st in - aux i1 ~len:len1 (aux i2 ~len:len2 acc) - in - try Some (aux i ~len []) with Backtrack -> None + 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 - (** {6 Fueled Generators} *) - - type 'a t = fuel -> state -> (fuel * 'a) option - - let return x fuel _st = _consume 1 fuel x - - let return' fuel x fuel' _st = _consume fuel fuel' x - - let flat_map f g fuel st = - match g fuel st with - | None -> None - | Some (fuel, x) -> f x fuel st - - let (>>=) g f = flat_map f g - - let map f g fuel st = - match g fuel st with - | None -> None - | Some (fuel, x) -> Some (fuel, f x) - - let (>|=) g f = map f g - - let consume fuel _st = _consume 1 fuel () - - let consume' fuel fuel' _st = _consume fuel fuel' () - - let fail _fuel _st = None - - let retry ?(max=10) g fuel st = - let rec aux n = - match g fuel st with +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 + in + aux max - let rec try_successively l fuel st = match l with - | [] -> None - | g :: l' -> - begin match g fuel st with - | None -> try_successively l' fuel st - | Some _ as res -> res - end +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] +let () a b = try_successively [a;b] - let rec fix f fuel st = f (fix f) fuel st +exception Backtrack - let lift g fuel st = _consume 1 fuel (g st) +let _choose_array_call a f st = + try + f (_choose_array a st) + with Invalid_argument _ -> raise Backtrack - let lift' d g fuel st = _consume d fuel (g st) +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 run ?(fuel=fun st -> Random.State.int st 40) f st = - match f (fuel st) st with - | None -> None - | Some (_fuel, x) -> Some x +let pure x _st = x - exception GenFailure +let (<*>) f g st = f st (g st) + +let __default_state = Random.State.make_self_init () + +let run ?(st=__default_state) g = g st - let run_exn ?fuel f st = - match run ?fuel f st with - | None -> raise GenFailure - | Some x -> x -end diff --git a/core/CCRandom.mli b/core/CCRandom.mli index 22b48ca5..fcf00d42 100644 --- a/core/CCRandom.mli +++ b/core/CCRandom.mli @@ -45,98 +45,72 @@ val map : ('a -> 'b) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t -val choose : 'a t list -> 'a t -(** Choose a generator within the list. +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 t +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 *) -(** {2 Fuel and Backtracking} *) +val replicate : int -> 'a t -> 'a list t -module Fuel : sig - type fuel = int - (** The fuel is a value that represents some "resource" used by the - random generator. *) +val small_int : int t - val split : fuel -> (fuel * fuel) option t - (** Split a (fuel) value [n] into [n1,n2] where [n = n1 + n2]. - @return [None] if the value is too small *) +val int : int -> int t - val split_list : fuel -> len:int -> fuel list option t - (** Split a (fuel) 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 int_range : int -> int -> int t +(** Inclusive range *) - (** {6 Fueled Generators} *) +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 *) - type 'a t = fuel -> state -> (fuel * 'a) option - (** Fueled generators use some fuel to generate a value. - Can fail by lack of fuel. *) +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 return : 'a -> 'a t - (** [return x] is the generator that always returns [x], and consumes one - fuel doing it. *) +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 return' : fuel -> 'a -> 'a t - (** [return' f x] returns [x] but also consumes [fuel]. *) +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 flat_map : ('a -> 'b t) -> 'a t -> 'b t +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 (>>=) : 'a t -> ('a -> 'b t) -> 'b t +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 *) - val map : ('a -> 'b) -> 'a t -> 'b t +(** {6 Applicative} *) - val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val pure : 'a -> 'a t - val consume : unit t - (** Consume one fuel value *) +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - val consume' : fuel -> unit t - (** Consume the given amount of fuel *) +(** {6 Run a generator} *) - val fail : 'a t - (** Always fails. *) +val run : ?st:state -> 'a t -> 'a +(** Using a random state (possibly the one in argument) run a generator *) - val retry : ?max:int -> 'a t -> 'a 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 t list -> 'a 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 t -> 'a t -> 'a 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 : ('a t -> 'a t) -> 'a t - (** Recursion combinators, for building (fueled) recursive values *) - - val lift : 'a random_gen -> 'a t - (** lifts a regular random generator into a fueled one, that consumes - one fuel unit *) - - val lift' : fuel -> 'a random_gen -> 'a t - (** lifts a regular random generator into a fueled one, that consumes - one fuel unit *) - - (** {6 Running} *) - - val run : ?fuel:fuel random_gen -> 'a t -> 'a option random_gen - (** Run the given fueled generator with an amount of fuel - given by the [fuel] generator. - @return None if the *) - - exception GenFailure - - val run_exn : ?fuel:fuel random_gen -> 'a t -> 'a random_gen - (** Same as {!run}, but in case of failure it raises an exception. - @raise GenFailure in case the generator fails *) -end 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/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'); + () + From 1e2ac4c39b0d18ed1d233fdba0e7dd7968f77e98 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 18:52:38 +0200 Subject: [PATCH 08/15] tests for bitvectors --- core/CCBV.ml | 80 ++++++++++++++++++++++++++++++++++++++++++++++++- core/CCBV.mli | 9 ++++++ core/CCBool.ml | 2 ++ core/CCBool.mli | 2 ++ 4 files changed, 92 insertions(+), 1 deletion(-) 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 From 696d1f27cfbedc82c17e8f202140e10fd911a22e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 22:46:34 +0200 Subject: [PATCH 09/15] update of FQueue with a richer, more consistent api --- core/CCFQueue.ml | 59 ++++++++++++++++++++++++++------------------ core/CCFQueue.mli | 35 +++++++++++++++++++------- tests/test_fQueue.ml | 12 ++++----- 3 files changed, 67 insertions(+), 39 deletions(-) diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 1e76711b..6b820ee2 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -35,35 +35,42 @@ let empty = { tl = []; } -let is_empty q = q.hd = [] && q.tl = [] +(* invariant: if hd=[], then tl=[] *) +let _make hd tl = match hd with + | [] -> {hd=List.rev tl; tl=[] } + | _::_ -> {hd; tl; } -let push q x = {q with tl = x :: q.tl; } +let is_empty q = q.hd = [] -let rec list_last l = match l with - | [] -> assert false - | [x] -> x - | _::l' -> list_last l' +let push x q = {q with tl = x :: q.tl; } -let peek q = - match q.hd, q.tl with - | [], [] -> raise (Invalid_argument "Queue.peek") - | [], _::_ -> - list_last q.tl - | x::_, _ -> x +let snoc q x = push x q -(* 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 +let peek_exn q = + match q.hd with + | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | x::_ -> x + +let peek q = match q.hd with + | [] -> None + | x::_ -> Some x + +let pop_exn q = + match q.hd with + | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") + | x::hd' -> + let q' = _make hd' q.tl in x, q' -let junk q = snd (pop q) +let pop q = + try Some (pop_exn q) + with Invalid_argument _ -> None + +let junk q = + try + let _, q' = pop_exn q in + q' + with Invalid_argument _ -> q (** Append two queues. Elements from the second one come after elements of the first one *) @@ -72,8 +79,12 @@ let append q1 q2 = tl=q2.tl @ (List.rev_append q2.hd q1.tl); } +let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; } + let size q = List.length q.hd + List.length q.tl +let (>|=) q f = map f q + 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' @@ -86,5 +97,5 @@ let to_seq q = fun k -> iter k q let of_seq seq = let q = ref empty in - seq (fun x -> q := push !q x); + seq (fun x -> q := push x !q); !q diff --git a/core/CCFQueue.mli b/core/CCFQueue.mli index 84fbd068..53cc8b0d 100644 --- a/core/CCFQueue.mli +++ b/core/CCFQueue.mli @@ -25,28 +25,45 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Functional queues (fifo)} *) -type 'a t +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 *) +val push : 'a -> 'a t -> 'a t +(** Push element at the end of the queue *) -val peek : 'a t -> 'a - (** Get first element, or raise Invalid_argument *) +val snoc : 'a t -> 'a -> 'a t +(** Flip version of {!push} *) -val pop : 'a t -> 'a * 'a t - (** Get and remove the first element, or raise Invalid_argument *) +val peek : 'a t -> 'a option +(** First element of the queue *) + +val peek_exn : 'a t -> 'a +(** Same as {!peek} but + @raise Invalid_argument if the queue is empty *) + +val pop : 'a t -> ('a * 'a t) option +(** Get and remove the first element *) + +val pop_exn : 'a t -> ('a * 'a t) +(** Same as {!pop}, but fails on empty queues. + @raise Invalid_argument if the queue is empty *) val junk : 'a t -> 'a t - (** Remove first element. If queue is empty, do nothing. *) + (** Remove first element. If the queue is empty, do nothing. *) 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) *) diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml index a4c5c48a..4843db56 100644 --- a/tests/test_fQueue.ml +++ b/tests/test_fQueue.ml @@ -9,19 +9,19 @@ let test_empty () = OUnit.assert_bool "is_empty" (FQueue.is_empty q) let test_push () = - let q = List.fold_left FQueue.push FQueue.empty [1;2;3;4;5] in + let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in let q = FQueue.junk q in - let q = List.fold_left FQueue.push q [6;7;8] in + let q = List.fold_left FQueue.snoc q [6;7;8] in let l = Sequence.to_list (FQueue.to_seq q) in OUnit.assert_equal [2;3;4;5;6;7;8] l let test_pop () = let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let x, q = FQueue.pop q in + let x, q = FQueue.pop_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.peek_exn q); + let x, q = FQueue.pop_exn q in OUnit.assert_equal 2 x; () From a87a5b03159ac8cfd30001ba16b578b2f2ea04dc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 00:43:43 +0200 Subject: [PATCH 10/15] CCFQueue is now a functional double-ended queue --- core/CCFQueue.ml | 312 +++++++++++++++++++++++++++++++++++-------- core/CCFQueue.mli | 89 +++++++++--- tests/test_fQueue.ml | 12 +- 3 files changed, 335 insertions(+), 78 deletions(-) diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 6b820ee2..8c2cc3a1 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -25,77 +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 *) +type 'a sequence = ('a -> unit) -> unit +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] +type 'a equal = 'a -> 'a -> bool -let empty = { - hd = []; - tl = []; -} +(** {2 Basics} *) -(* invariant: if hd=[], then tl=[] *) -let _make hd tl = match hd with - | [] -> {hd=List.rev tl; tl=[] } - | _::_ -> {hd; tl; } +type 'a digit = + | Zero + | One of 'a + | Two of 'a * 'a + | Three of 'a * 'a * 'a -let is_empty q = q.hd = [] +type 'a t = + | Shallow of 'a digit + | Deep of 'a digit * ('a * 'a) t lazy_t * 'a digit -let push x q = {q with tl = x :: q.tl; } +let empty = Shallow Zero -let snoc q x = push x q +exception Empty -let peek_exn q = - match q.hd with - | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") - | x::_ -> x +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 peek q = match q.hd with - | [] -> None - | x::_ -> Some x +let is_empty = function + | Shallow Zero -> true + | _ -> false -let pop_exn q = - match q.hd with - | [] -> assert (q.tl = []); raise (Invalid_argument "Queue.peek") - | x::hd' -> - let q' = _make hd' q.tl in - x, q' +let _empty = Lazy.from_val empty -let pop q = - try Some (pop_exn q) - with Invalid_argument _ -> None +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 junk q = - try - let _, q' = pop_exn q in - q' - with Invalid_argument _ -> q +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 snd (take_front_exn q) + with Empty -> q + +let tail q = + try fst (take_back_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 -(** 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); - } + match q1, q2 with + | Shallow Zero, _ -> q2 + | _, Shallow Zero -> q1 + | _ -> add_seq_front (to_seq q1) q2 -let map f q = { hd=List.map f q.hd; tl=List.map f q.tl; } +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 size q = List.length q.hd + List.length q.tl +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 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 _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 iter f q = fold (fun () x -> f x) () q +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 -type 'a sequence = ('a -> unit) -> unit +let iter f q = to_seq q f -let to_seq q = fun k -> iter k q +let of_list l = List.fold_left snoc empty l -let of_seq seq = - let q = ref empty in - seq (fun x -> q := push x !q); - !q +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 53cc8b0d..d78481fa 100644 --- a/core/CCFQueue.mli +++ b/core/CCFQueue.mli @@ -23,7 +23,13 @@ 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 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 *) @@ -32,28 +38,61 @@ val empty : 'a t val is_empty : 'a t -> bool -val push : 'a -> 'a t -> 'a t -(** Push element at the end of the queue *) +exception Empty + +val cons : 'a -> 'a t -> 'a t +(** Push element at the front of the queue *) val snoc : 'a t -> 'a -> 'a t -(** Flip version of {!push} *) +(** Push element at the end of the queue *) -val peek : 'a t -> 'a option -(** First element of the queue *) - -val peek_exn : 'a t -> 'a -(** Same as {!peek} but - @raise Invalid_argument if the queue is empty *) - -val pop : 'a t -> ('a * 'a t) option +val take_front : 'a t -> ('a * 'a t) option (** Get and remove the first element *) -val pop_exn : 'a t -> ('a * 'a t) -(** Same as {!pop}, but fails on empty queues. - @raise Invalid_argument if the queue is empty *) +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 junk : 'a t -> 'a t - (** Remove first element. If the queue is empty, do nothing. *) +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 @@ -66,13 +105,25 @@ val map : ('a -> 'b) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val size : 'a t -> int - (** Number of elements in the queue (linear in time) *) +(** Number of elements in the queue (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/tests/test_fQueue.ml b/tests/test_fQueue.ml index 4843db56..c823488b 100644 --- a/tests/test_fQueue.ml +++ b/tests/test_fQueue.ml @@ -10,18 +10,18 @@ let test_empty () = let test_push () = let q = List.fold_left FQueue.snoc FQueue.empty [1;2;3;4;5] in - let q = FQueue.junk q in + let q = FQueue.tail q in let q = List.fold_left FQueue.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 let test_pop () = - let q = FQueue.of_seq (Sequence.of_list [1;2;3;4]) in - let x, q = FQueue.pop_exn 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.snoc q [5;6;7] in - OUnit.assert_equal 2 (FQueue.peek_exn q); - let x, q = FQueue.pop_exn q in + OUnit.assert_equal 2 (FQueue.first_exn q); + let x, q = FQueue.take_front_exn q in OUnit.assert_equal 2 x; () @@ -39,7 +39,7 @@ let test_fold () = () let suite = - "test_pQueue" >::: + "test_FQueue" >::: [ "test_empty" >:: test_empty; "test_push" >:: test_push; "test_pop" >:: test_pop; From 2395ebb2adf09f2cb88ff93fb60211817120b05b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 01:26:53 +0200 Subject: [PATCH 11/15] make test will now run both oUnit and qtest --- Makefile | 12 +++++++++--- _oasis | 2 +- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 5751211b..8ebd6c85 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 @@ -79,7 +81,11 @@ push-stable: all git push origin git checkout master -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/_oasis b/_oasis index bc8324f0..80b0eacc 100644 --- a/_oasis +++ b/_oasis @@ -179,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) From 891725157ecc63fcacc7b2c5cb2edb204adc7569 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 01:27:17 +0200 Subject: [PATCH 12/15] fix bug in CCFqueue --- core/CCFQueue.ml | 4 ++-- tests/test_fQueue.ml | 6 ++++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 8c2cc3a1..80aea967 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -172,11 +172,11 @@ let last q = let last_exn q = snd (take_back_exn q) let init q = - try snd (take_front_exn q) + try fst (take_back_exn q) with Empty -> q let tail q = - try fst (take_back_exn q) + try snd (take_front_exn q) with Empty -> q let add_seq_front seq q = diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml index c823488b..33082e5e 100644 --- a/tests/test_fQueue.ml +++ b/tests/test_fQueue.ml @@ -8,12 +8,14 @@ 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.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_list [1;2;3;4] in @@ -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 From cac3500177a056bcdcef45d01730a1074ca6d54e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 01:27:43 +0200 Subject: [PATCH 13/15] updated CCLeftistheap with a brand new functorial interface, with more conversion functions, etc. --- core/CCLeftistheap.ml | 312 +++++++++++++++++++++++--------------- core/CCLeftistheap.mli | 80 ++++++---- tests/test_leftistheap.ml | 29 ++-- 3 files changed, 250 insertions(+), 171 deletions(-) diff --git a/core/CCLeftistheap.ml b/core/CCLeftistheap.ml index 1a73853c..b3464cf1 100644 --- a/core/CCLeftistheap.ml +++ b/core/CCLeftistheap.ml @@ -25,156 +25,216 @@ 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 tree = unit -> [`Nil | `Node of 'a * 'a tree list] -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 +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 -let empty_with ~leq = - { tree = Empty; - leq; - } +module type S = sig + type elt + type t -let empty = - { tree = Empty; - leq = (fun x y -> x <= y); - } + val empty : t + (** Empty heap *) -let is_empty heap = - match heap.tree with - | Empty -> true - | _ -> false + val is_empty : t -> bool + (** Is the heap empty? *) -(** Rank of the tree *) -let rank_tree t = match t with - | Empty -> 0 - | Node (r, _, _, _) -> r + exception Empty -(** 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) + val merge : t -> t -> t + (** Merge two heaps *) -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) + val insert : elt -> t -> t + (** Insert a value in the heap *) -let merge h1 h2 = - let tree = merge_tree h1.leq h1.tree h2.tree in - { tree; leq=h1.leq; } + val add : t -> elt -> t + (** Synonym to {!insert} *) -let insert heap x = - let tree = merge_tree heap.leq (Node (1, x, Empty, Empty)) heap.tree in - { heap with tree; } + val filter : (elt -> bool) -> t -> t + (** Filter values, only retaining the ones that satisfy the predicate. + Linear time at least. *) -let add = insert + val find_min : t -> elt option + (** Find minimal element *) -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; } + val find_min_exn : t -> elt + (** Same as {!find_min} but can fail + @raise Empty if the heap is empty *) -let find_min heap = - match heap.tree with - | Empty -> raise Not_found - | Node (_, x, _, _) -> x + 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 *) -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 + val take_exn : t -> t * elt + (** Same as {!take}, but can fail. + @raise Empty if the heap is empty *) -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') + val iter : (elt -> unit) -> t -> unit + (** Iterate on elements *) -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 + val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a + (** Fold on all values *) -let fold f acc h = - let rec fold acc h = match h with - | Empty -> acc - | Node (_, x, a, b) -> + 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 acc a in - fold acc b - in fold acc h.tree + let acc = fold f acc a in + fold f acc b -let size heap = - let r = ref 0 in - iter (fun _ -> incr r) heap; - !r + let rec size = function + | E -> 0 + | N (_,_,l,r) -> 1 + size l + size r -let of_seq heap seq = - let h = ref heap in - seq (fun x -> h := insert !h x); - !h + (** {2 Conversions} *) -let to_seq h k = iter k h + 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 rec of_klist h l = match l() with - | `Nil -> h - | `Cons (x, l') -> - let h' = add h x in - of_klist h' l' + let of_list l = List.fold_left add empty 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 of_seq h seq = + let h = ref h in + seq (fun x -> h := insert x !h); + !h -let rec of_gen h g = match g () with - | None -> h - | Some x -> - of_gen (add h x) g + let to_seq h k = iter k h -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 + 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/CCLeftistheap.mli index 9836ce9a..30e5b939 100644 --- a/core/CCLeftistheap.mli +++ b/core/CCLeftistheap.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 tree = unit -> [`Nil | `Node of 'a * 'a tree list] type 'a gen = unit -> 'a option -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/tests/test_leftistheap.ml b/tests/test_leftistheap.ml index 2204ca8c..1175f22c 100644 --- a/tests/test_leftistheap.ml +++ b/tests/test_leftistheap.ml @@ -3,26 +3,27 @@ open OUnit -module Leftistheap = CCLeftistheap module Sequence = CCSequence -let empty = Leftistheap.empty +module H = CCLeftistheap.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'); () From 9e2c8ec392324d7183f3549087e24e082de83d72 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 01:36:15 +0200 Subject: [PATCH 14/15] rename CCLeftistheap to CCHeap, for it is a simpler name --- _oasis | 2 +- core/{CCLeftistheap.ml => CCHeap.ml} | 0 core/{CCLeftistheap.mli => CCHeap.mli} | 0 tests/run_tests.ml | 2 +- tests/{test_leftistheap.ml => test_CCHeap.ml} | 2 +- 5 files changed, 3 insertions(+), 3 deletions(-) rename core/{CCLeftistheap.ml => CCHeap.ml} (100%) rename core/{CCLeftistheap.mli => CCHeap.mli} (100%) rename tests/{test_leftistheap.ml => test_CCHeap.ml} (95%) diff --git a/_oasis b/_oasis index 80b0eacc..627456dc 100644 --- a/_oasis +++ b/_oasis @@ -40,7 +40,7 @@ Library "containers" Path: core Modules: CCVector, CCDeque, CCGen, CCSequence, CCFQueue, CCMultiMap, CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, - CCLeftistheap, CCList, CCOpt, CCPair, CCFun, CCHash, + CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCRandom, CCLinq FindlibName: containers diff --git a/core/CCLeftistheap.ml b/core/CCHeap.ml similarity index 100% rename from core/CCLeftistheap.ml rename to core/CCHeap.ml diff --git a/core/CCLeftistheap.mli b/core/CCHeap.mli similarity index 100% rename from core/CCLeftistheap.mli rename to core/CCHeap.mli 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 95% rename from tests/test_leftistheap.ml rename to tests/test_CCHeap.ml index 1175f22c..a0c97a79 100644 --- a/tests/test_leftistheap.ml +++ b/tests/test_CCHeap.ml @@ -5,7 +5,7 @@ open OUnit module Sequence = CCSequence -module H = CCLeftistheap.Make(struct type t = int let leq x y =x<=y end) +module H = CCHeap.Make(struct type t = int let leq x y =x<=y end) let empty = H.empty From b01a302f07e8e2e5d6d382e48406b7ab4a188dd4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 25 Jun 2014 01:36:45 +0200 Subject: [PATCH 15/15] updated readme --- README.md | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) 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