From 9da54f3e5a084dd6b650beab2e60dcb82c400bf1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 24 Jun 2014 14:06:48 +0200 Subject: [PATCH] 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