ocaml-containers/core/CCGen.ml
Simon Cruanes 113ea6d395 updated and fixed things in core/:
fixed warnings, updated Sequence/Gen with tests and more recent interface; added printers
2014-05-17 01:00:00 +02:00

1716 lines
43 KiB
OCaml

(*
Copyright (c) 2013, Simon Cruanes
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. Redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
(** {1 Restartable generators} *)
(** {2 Global type declarations} *)
type 'a t = unit -> 'a option
type 'a gen = 'a t
(** {2 Common signature for transient and restartable generators} *)
module type S = sig
type 'a t
val empty : 'a t
(** Empty generator, with no elements *)
val singleton : 'a -> 'a t
(** One-element generator *)
val repeat : 'a -> 'a t
(** Repeat same element endlessly *)
val iterate : 'a -> ('a -> 'a) -> 'a t
(** [iterate x f] is [[x; f x; f (f x); f (f (f x)); ...]] *)
val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t
(** Dual of {!fold}, with a deconstructing operation. It keeps on
unfolding the ['b] value into a new ['b], and a ['a] which is yielded,
until [None] is returned. *)
val init : ?limit:int -> (int -> 'a) -> 'a t
(** Calls the function, starting from 0, on increasing indices.
If [limit] is provided and is a positive int, iteration will
stop at the limit (excluded).
For instance [init ~limit:4 id] will yield 0, 1, 2, and 3. *)
(** {2 Basic combinators} *)
val is_empty : _ t -> bool
(** Check whether the enum is empty. *)
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
(** Fold on the generator, tail-recursively *)
val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a
(** Fold on non-empty sequences (otherwise raise Invalid_argument) *)
val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t
(** Like {!fold}, but keeping successive values of the accumulator *)
val iter : ('a -> unit) -> 'a t -> unit
(** Iterate on the enum *)
val iteri : (int -> 'a -> unit) -> 'a t -> unit
(** Iterate on elements with their index in the enum, from 0 *)
val length : _ t -> int
(** Length of an enum (linear time) *)
val map : ('a -> 'b) -> 'a t -> 'b t
(** Lazy map. No iteration is performed now, the function will be called
when the result is traversed. *)
val append : 'a t -> 'a t -> 'a t
(** Append the two enums; the result contains the elements of the first,
then the elements of the second enum. *)
val flatten : 'a gen t -> 'a t
(** Flatten the enumeration of generators *)
val flat_map : ('a -> 'b gen) -> 'a t -> 'b t
(** Monadic bind; each element is transformed to a sub-enum
which is then iterated on, before the next element is processed,
and so on. *)
val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool
(** Is the given element, member of the enum? *)
val take : int -> 'a t -> 'a t
(** Take at most n elements *)
val drop : int -> 'a t -> 'a t
(** Drop n elements *)
val nth : int -> 'a t -> 'a
(** n-th element, or Not_found
@raise Not_found if the generator contains less than [n] arguments *)
val take_nth : int -> 'a t -> 'a t
(** [take_nth n g] returns every element of [g] whose index
is a multiple of [n]. For instance [take_nth 2 (1--10) |> to_list]
will return [1;3;5;7;9] *)
val filter : ('a -> bool) -> 'a t -> 'a t
(** Filter out elements that do not satisfy the predicate. *)
val take_while : ('a -> bool) -> 'a t -> 'a t
(** Take elements while they satisfy the predicate *)
val drop_while : ('a -> bool) -> 'a t -> 'a t
(** Drop elements while they satisfy the predicate *)
val filter_map : ('a -> 'b option) -> 'a t -> 'b t
(** _maps some elements to 'b, drop the other ones *)
val zip_index : 'a t -> (int * 'a) t
(** Zip elements with their index in the enum *)
val unzip : ('a * 'b) t -> 'a t * 'b t
(** Unzip into two sequences, splitting each pair *)
val partition : ('a -> bool) -> 'a t -> 'a t * 'a t
(** [partition p l] returns the elements that satisfy [p],
and the elements that do not satisfy [p] *)
val for_all : ('a -> bool) -> 'a t -> bool
(** Is the predicate true for all elements? *)
val exists : ('a -> bool) -> 'a t -> bool
(** Is the predicate true for at least one element? *)
val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a
(** Minimum element, according to the given comparison function.
@raise Invalid_argument if the generator is empty *)
val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a
(** Maximum element, see {!min}
@raise Invalid_argument if the generator is empty *)
val eq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool
(** Equality of generators. *)
val lexico : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
(** Lexicographic comparison of generators. If a generator is a prefix
of the other one, it is considered smaller. *)
val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int
(** Synonym for {! lexico} *)
val find : ('a -> bool) -> 'a t -> 'a option
(** [find p e] returns the first element of [e] to satisfy [p],
or None. *)
val sum : int t -> int
(** Sum of all elements *)
(** {2 Multiple iterators} *)
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
(** map on the two sequences. Stops once one of them is exhausted.*)
val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit
(** Iterate on the two sequences. Stops once one of them is exhausted.*)
val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc
(** Fold the common prefix of the two iterators *)
val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
(** Succeeds if all pairs of elements satisfy the predicate.
Ignores elements of an iterator if the other runs dry. *)
val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
(** Succeeds if some pair of elements satisfy the predicate.
Ignores elements of an iterator if the other runs dry. *)
val zip_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
(** Combine common part of the enums (stops when one is exhausted) *)
val zip : 'a t -> 'b t -> ('a * 'b) t
(** Zip together the common part of the enums *)
(** {2 Complex combinators} *)
val merge : 'a gen t -> 'a t
(** Pick elements fairly in each sub-generator. The merge of enums
[e1, e2, ... ] picks elements in [e1], [e2],
in [e3], [e1], [e2] .... Once a generator is empty, it is skipped;
when they are all empty, and none remains in the input,
their merge is also empty.
For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *)
val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t
(** Intersection of two sorted sequences. Only elements that occur in both
inputs appear in the output *)
val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t
(** Merge two sorted sequences into a sorted sequence *)
val sorted_merge_n : ?cmp:('a -> 'a -> int) -> 'a t list -> 'a t
(** Sorted merge of multiple sorted sequences *)
val tee : ?n:int -> 'a t -> 'a gen list
(** Duplicate the enum into [n] generators (default 2). The generators
share the same underlying instance of the enum, so the optimal case is
when they are consumed evenly *)
val round_robin : ?n:int -> 'a t -> 'a gen list
(** Split the enum into [n] generators in a fair way. Elements with
[index = k mod n] with go to the k-th enum. [n] default value
is 2. *)
val interleave : 'a t -> 'a t -> 'a t
(** [interleave a b] yields an element of [a], then an element of [b],
and so on. When a generator is exhausted, this behaves like the
other generator. *)
val intersperse : 'a -> 'a t -> 'a t
(** Put the separator element between all elements of the given enum *)
val product : 'a t -> 'b t -> ('a * 'b) t
(** Cartesian product, in no predictable order. Works even if some of the
arguments are infinite. *)
val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t
(** Group equal consecutive elements together. *)
val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t
(** Remove consecutive duplicate elements. Basically this is
like [fun e -> map List.hd (group e)]. *)
val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t
(** Sort according to the given comparison function. The enum must be finite. *)
val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t
(** Sort and remove duplicates. The enum must be finite. *)
val chunks : int -> 'a t -> 'a array t
(** [chunks n e] returns a generator of arrays of length [n], composed
of successive elements of [e]. The last array may be smaller
than [n] *)
(* TODO later
val permutations : 'a t -> 'a gen t
(** Permutations of the enum. Each permutation becomes unavailable once
the next one is produced. *)
val combinations : int -> 'a t -> 'a t t
(** Combinations of given length. *)
val powerSet : 'a t -> 'a t t
(** All subsets of the enum (in no particular order) *)
*)
(** {2 Basic conversion functions} *)
val of_list : 'a list -> 'a t
(** Enumerate elements of the list *)
val to_list : 'a t -> 'a list
(** non tail-call trasnformation to list, in the same order *)
val to_rev_list : 'a t -> 'a list
(** Tail call conversion to list, in reverse order (more efficient) *)
val to_array : 'a t -> 'a array
(** Convert the enum to an array (not very efficient) *)
val of_array : ?start:int -> ?len:int -> 'a array -> 'a t
(** Iterate on (a slice of) the given array *)
val rand_int : int -> int t
(** Random ints in the given range. *)
val int_range : int -> int -> int t
(** [int_range a b] enumerates integers between [a] and [b], included. [a]
is assumed to be smaller than [b]. *)
module Infix : sig
val (--) : int -> int -> int t
(** Synonym for {! int_range} *)
val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t
(** Monadic bind operator *)
end
val (--) : int -> int -> int t
(** Synonym for {! int_range} *)
val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t
(** Monadic bind operator *)
val pp : ?start:string -> ?stop:string -> ?sep:string -> ?horizontal:bool ->
(Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
(** Pretty print the content of the generator on a formatter. *)
end
(** {2 Transient generators} *)
let empty () = None
(*$T empty
empty |> to_list = []
*)
let singleton x =
let first = ref true in
fun () ->
if !first then (first := false; Some x) else None
(*T singleton
singleton 1 |> to_list = [1]
singleton "foo" |> to_list = ["foo"]
*)
let repeat x () = Some x
(*$T repeat
repeat 42 |> take 3 |> to_list = [42; 42; 42]
*)
let repeatedly f () = Some (f ())
(*$T repeatedly
repeatedly (let r = ref 0 in fun () -> incr r; !r) \
|> take 5 |> to_list = [1;2;3;4;5]
*)
let iterate x f =
let cur = ref x in
fun () ->
let x = !cur in
cur := f !cur;
Some x
(*$T iterate
iterate 0 ((+)1) |> take 5 |> to_list = [0;1;2;3;4]
*)
let next gen = gen ()
let get gen = gen ()
let get_exn gen =
match gen () with
| Some x -> x
| None -> raise (Invalid_argument "Gen.get_exn")
(*$R get_exn
let g = of_list [1;2;3] in
assert_equal 1 (get_exn g);
assert_equal 2 (get_exn g);
assert_equal 3 (get_exn g);
assert_raises (Invalid_argument "Gen.get_exn") (fun () -> get_exn g)
*)
let junk gen = ignore (gen ())
let rec fold f acc gen =
match gen () with
| None -> acc
| Some x -> fold f (f acc x) gen
(*$Q
(Q.list Q.small_int) (fun l -> \
of_list l |> fold (fun l x->x::l) [] = List.rev l)
*)
let reduce f g =
let acc = match g () with
| None -> raise (Invalid_argument "reduce")
| Some x -> x
in
fold f acc g
(* Dual of {!fold}, with a deconstructing operation *)
let unfold f acc =
let acc = ref acc in
fun () ->
match f !acc with
| None -> None
| Some (x, acc') ->
acc := acc';
Some x
(*$T unfold
unfold (fun (prev,cur) -> Some (prev, (cur,prev+cur))) (0,1) \
|> take 7 |> to_list = [0; 1; 1; 2; 3; 5; 8]
*)
let init ?(limit=max_int) f =
let r = ref 0 in
fun () ->
if !r >= limit
then None
else
let x = f !r in
let _ = incr r in
Some x
(*$T init
init ~limit:5 (fun i->i) |> to_list = [0;1;2;3;4]
*)
let rec iter f gen =
match gen() with
| None -> ()
| Some x -> f x; iter f gen
let iteri f gen =
let rec iteri i = match gen() with
| None -> ()
| Some x -> f i x; iteri (i+1)
in
iteri 0
let is_empty gen = match gen () with
| None -> true
| Some _ -> false
(*$T
is_empty empty
not (is_empty (singleton 2))
*)
let length gen =
fold (fun acc _ -> acc + 1) 0 gen
(*$Q
(Q.list Q.small_int) (fun l -> \
of_list l |> length = List.length l)
*)
(* useful state *)
type 'a run_state =
| Init
| Run of 'a
| Stop
let scan f acc g =
let state = ref Init in
fun () ->
match !state with
| Init ->
state := Run acc;
Some acc
| Stop -> None
| Run acc ->
match g() with
| None -> state := Stop; None
| Some x ->
let acc' = f acc x in
state := Run acc';
Some acc'
(*$T scan
scan (fun acc x -> x+1::acc) [] (1--5) |> to_list \
= [[]; [2]; [3;2]; [4;3;2]; [5;4;3;2]; [6;5;4;3;2]]
*)
(** {3 Lazy} *)
let map f gen =
let stop = ref false in
fun () ->
if !stop then None
else match gen() with
| None -> stop:= true; None
| Some x -> Some (f x)
(*$Q map
(Q.list Q.small_int) (fun l -> \
let f x = x*2 in \
of_list l |> map f |> to_list = List.map f l)
*)
let append gen1 gen2 =
let first = ref true in
let rec next() =
if !first
then match gen1() with
| (Some _) as x -> x
| None -> first:=false; next()
else gen2()
in next
(*$Q
(Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \
append (of_list l1) (of_list l2) |> to_list = l1 @ l2)
*)
let flatten next_gen =
let state = ref Init in
(* get next element *)
let rec next () =
match !state with
| Init -> get_next_gen()
| Run gen ->
begin match gen () with
| None -> get_next_gen ()
| (Some _) as x -> x
end
| Stop -> None
and get_next_gen() = match next_gen() with
| None -> state := Stop; None
| Some gen -> state := Run gen; next()
in
next
let flat_map f next_elem =
let state = ref Init in
let rec next() =
match !state with
| Init -> get_next_gen()
| Run gen ->
begin match gen () with
| None -> get_next_gen ()
| (Some _) as x -> x
end
| Stop -> None
and get_next_gen() = match next_elem() with
| None -> state:=Stop; None
| Some x ->
try state := Run (f x); next()
with e -> state := Stop; raise e
in
next
(*$Q flat_map
(Q.list Q.small_int) (fun l -> \
let f x = of_list [x;x*2] in \
eq (map f (of_list l) |> flatten) (flat_map f (of_list l)))
*)
let mem ?(eq=(=)) x gen =
let rec mem eq x gen =
match gen() with
| Some y -> eq x y || mem eq x gen
| None -> false
in mem eq x gen
let take n gen =
assert (n >= 0);
let count = ref 0 in (* how many yielded elements *)
fun () ->
if !count = n || !count = ~-1
then None
else match gen() with
| None -> count := ~-1; None (* indicate stop *)
| (Some _) as x -> incr count; x
(*$Q
(Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \
of_list l |> take n |> length = Pervasives.min n (List.length l))
*)
(* call [gen] at most [n] times, and stop *)
let rec __drop n gen =
if n = 0 then ()
else match gen() with
| Some _ -> __drop (n-1) gen
| None -> ()
let drop n gen =
assert (n >= 0);
let dropped = ref false in
fun () ->
if !dropped
then gen()
else begin
(* drop [n] elements and yield the next element *)
dropped := true;
__drop n gen;
gen()
end
(*$Q
(Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \
let g1,g2 = take n (of_list l), drop n (of_list l) in \
append g1 g2 |> to_list = l)
*)
let nth n gen =
assert (n>=0);
__drop n gen;
match gen () with
| None -> raise Not_found
| Some x -> x
(*$= nth & ~printer:string_of_int
4 (nth 4 (0--10))
8 (nth 8 (0--10))
*)
(*$T
(try ignore (nth 11 (1--10)); false with Not_found -> true)
*)
let take_nth n gen =
assert (n>=1);
let i = ref n in
let rec next() =
match gen() with
| None -> None
| (Some _) as res when !i = n -> i:=1; res
| Some _ -> incr i; next()
in next
let filter p gen =
let rec next () =
(* wrap exception into option, for next to be tailrec *)
match gen() with
| None -> None
| (Some x) as res ->
if p x
then res (* yield element *)
else next () (* discard element *)
in next
(*$T
filter (fun x ->x mod 2 = 0) (1--10) |> to_list = [2;4;6;8;10]
*)
let take_while p gen =
let stop = ref false in
fun () ->
if !stop
then None
else match gen() with
| (Some x) as res ->
if p x then res else (stop := true; None)
| None -> stop:=true; None
(*$T
take_while (fun x ->x<10) (1--1000) |> eq (1--9)
*)
module DropWhileState = struct
type t =
| Stop
| Drop
| Yield
end
let drop_while p gen =
let open DropWhileState in
let state = ref Drop in
let rec next () =
match !state with
| Stop -> None
| Drop ->
begin match gen () with
| None -> state := Stop; None
| (Some x) as res ->
if p x then next() else (state:=Yield; res)
end
| Yield ->
begin match gen () with
| None -> state := Stop; None
| (Some x) as res -> res
end
in next
(*$T
drop_while (fun x-> x<10) (1--20) |> eq (10--20)
*)
let filter_map f gen =
(* tailrec *)
let rec next () =
match gen() with
| None -> None
| Some x ->
match f x with
| None -> next()
| (Some _) as res -> res
in next
(*$T
filter_map (fun x-> if x mod 2 = 0 then Some (string_of_int x) else None) (1--10) \
|> to_list = List.map string_of_int [2;4;6;8;10]
*)
let zip_index gen =
let r = ref ~-1 in
fun () ->
match gen() with
| None -> None
| Some x ->
incr r;
Some (!r, x)
(*$T
zip_index (1--5) |> to_list = [0,1; 1,2; 2,3; 3,4; 4,5]
*)
let unzip gen =
let stop = ref false in
let q1 = Queue.create () in
let q2 = Queue.create () in
let next_left () =
if Queue.is_empty q1
then if !stop then None
else match gen() with
| Some (x,y) ->
Queue.push y q2;
Some x
| None -> stop := true; None
else Some (Queue.pop q1)
in
let next_right () =
if Queue.is_empty q2
then if !stop then None
else match gen() with
| Some (x,y) ->
Queue.push x q1;
Some y
| None -> stop := true; None
else Some (Queue.pop q2)
in
next_left, next_right
(*$T
unzip (of_list [1,2;3,4]) |> (fun (x,y)-> to_list x, to_list y) \
= ([1;3], [2;4])
*)
(*$Q
(Q.list (Q.pair Q.small_int Q.small_int)) (fun l -> \
of_list l |> unzip |> (fun (x,y) -> to_list x,to_list y) = \
List.split l)
*)
(* [partition p l] returns the elements that satisfy [p],
and the elements that do not satisfy [p] *)
let partition p gen =
let qtrue = Queue.create () in
let qfalse = Queue.create () in
let stop = ref false in
let rec nexttrue () =
if Queue.is_empty qtrue
then if !stop then None
else match gen() with
| (Some x) as res ->
if p x then res else (Queue.push x qfalse; nexttrue())
| None -> stop:=true; None
else Some (Queue.pop qtrue)
and nextfalse() =
if Queue.is_empty qfalse
then if !stop then None
else match gen() with
| (Some x) as res ->
if p x then (Queue.push x qtrue; nextfalse()) else res
| None -> stop:= true; None
else Some (Queue.pop qfalse)
in
nexttrue, nextfalse
(*$T
partition (fun x -> x mod 2 = 0) (1--10) |> \
(fun (x,y)->to_list x, to_list y) = ([2;4;6;8;10], [1;3;5;7;9])
*)
let rec for_all p gen =
match gen() with
| None -> true
| Some x -> p x && for_all p gen
let rec exists p gen =
match gen() with
| None -> false
| Some x -> p x || exists p gen
let min ?(lt=fun x y -> x < y) gen =
let first = match gen () with
| Some x -> x
| None -> raise (Invalid_argument "min")
in
fold (fun min x -> if lt x min then x else min) first gen
(*$T
min (of_list [1;4;6;0;11; -2]) = ~-2
(try ignore (min empty); false with Invalid_argument _ -> true)
*)
let max ?(lt=fun x y -> x < y) gen =
let first = match gen () with
| Some x -> x
| None -> raise (Invalid_argument "max")
in
fold (fun max x -> if lt max x then x else max) first gen
(*$T
max (of_list [1;4;6;0;11; -2]) = 11
(try ignore (max empty); false with Invalid_argument _ -> true)
*)
let eq ?(eq=(=)) gen1 gen2 =
let rec check () =
match gen1(), gen2() with
| None, None -> true
| Some x1, Some x2 when eq x1 x2 -> check ()
| _ -> false
in
check ()
(*$Q
(Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \
eq (of_list l1)(of_list l2) = (l1 = l2))
*)
let lexico ?(cmp=Pervasives.compare) gen1 gen2 =
let rec lexico () =
match gen1(), gen2() with
| None, None -> 0
| Some x1, Some x2 ->
let c = cmp x1 x2 in
if c <> 0 then c else lexico ()
| Some _, None -> 1
| None, Some _ -> -1
in lexico ()
let compare ?cmp gen1 gen2 = lexico ?cmp gen1 gen2
(*$Q
(Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \
let sign x = if x < 0 then -1 else if x=0 then 0 else 1 in \
sign (compare (of_list l1)(of_list l2)) = sign (Pervasives.compare l1 l2))
*)
let rec find p e = match e () with
| None -> None
| Some x when p x -> Some x
| Some _ -> find p e
(*$T
find (fun x -> x>=5) (1--10) = Some 5
find (fun x -> x>5) (1--4) = None
*)
let sum e =
let rec sum acc = match e() with
| None -> acc
| Some x -> sum (x+acc)
in sum 0
(*$T
sum (1--10) = 55
*)
(** {2 Multiple Iterators} *)
let map2 f e1 e2 =
fun () -> match e1(), e2() with
| Some x, Some y -> Some (f x y)
| _ -> None
(*$T
map2 (+) (1--5) (1--4) |> eq (of_list [2;4;6;8])
map2 (+) (1--5) (repeat 0) |> eq (1--5)
*)
let rec iter2 f e1 e2 =
match e1(), e2() with
| Some x, Some y -> f x y; iter2 f e1 e2
| _ -> ()
(*$T iter2
let r = ref 0 in iter2 (fun _ _ -> incr r) (1--10) (4--6); !r = 3
*)
let rec fold2 f acc e1 e2 =
match e1(), e2() with
| Some x, Some y -> fold2 f (f acc x y) e1 e2
| _ -> acc
let rec for_all2 p e1 e2 =
match e1(), e2() with
| Some x, Some y -> p x y && for_all2 p e1 e2
| _ -> true
let rec exists2 p e1 e2 =
match e1(), e2() with
| Some x, Some y -> p x y || exists2 p e1 e2
| _ -> false
let zip_with f a b =
let stop = ref false in
fun () ->
if !stop then None
else match a(), b() with
| Some xa, Some xb -> Some (f xa xb)
| _ -> stop:=true; None
let zip a b = zip_with (fun x y -> x,y) a b
(*$Q
(Q.list Q.small_int) (fun l -> \
zip_with (fun x y->x,y) (of_list l) (of_list l) \
|> unzip |> fst |> to_list = l)
*)
(** {3 Complex combinators} *)
module MergeState = struct
type 'a t = {
gens : 'a gen Queue.t;
mutable state : my_state;
}
and my_state =
| NewGen
| YieldAndNew
| Yield
| Stop
end
(* state machine:
(NewGen -> YieldAndNew)* // then no more generators in next_gen, so
-> Yield* -> Stop *)
let merge next_gen =
let open MergeState in
let state = {gens = Queue.create(); state=NewGen;}in
(* recursive function to get next element *)
let rec next () =
match state.state with
| Stop -> None
| Yield -> (* only yield from generators in state.gens *)
if Queue.is_empty state.gens
then (state.state <- Stop; None)
else
let gen = Queue.pop state.gens in
begin match gen () with
| None -> next()
| (Some _) as res ->
Queue.push gen state.gens; (* put gen back in queue *)
res
end
| NewGen ->
begin match next_gen() with
| None ->
state.state <- Yield; (* exhausted *)
next()
| Some gen ->
Queue.push gen state.gens;
state.state <- YieldAndNew;
next()
end
| YieldAndNew -> (* yield element from queue, then get a new generator *)
if Queue.is_empty state.gens
then (state.state <- NewGen; next())
else
let gen = Queue.pop state.gens in
begin match gen () with
| None -> state.state <- NewGen; next()
| (Some _) as res ->
Queue.push gen state.gens;
state.state <- NewGen;
res
end
in next
(*$T
merge (of_list [of_list [1;3;5]; of_list [2;4;6]; of_list [7;8;9]]) \
|> to_list |> List.sort Pervasives.compare = [1;2;3;4;5;6;7;8;9]
*)
let intersection ?(cmp=Pervasives.compare) gen1 gen2 =
let x1 = ref (gen1 ()) in
let x2 = ref (gen2 ()) in
let rec next () =
match !x1, !x2 with
| Some y1, Some y2 ->
let c = cmp y1 y2 in
if c = 0 (* equal elements, yield! *)
then (x1 := gen1(); x2 := gen2(); Some y1)
else if c < 0 (* drop y1 *)
then (x1 := gen1 (); next ())
else (* drop y2 *)
(x2 := gen2(); next ())
| _ -> None
in next
(*$T
intersection (of_list [1;1;2;3;4;8]) (of_list [1;2;4;5;6;7;8;9]) \
|> to_list = [1;2;4;8]
*)
let sorted_merge ?(cmp=Pervasives.compare) gen1 gen2 =
let x1 = ref (gen1 ()) in
let x2 = ref (gen2 ()) in
fun () ->
match !x1, !x2 with
| None, None -> None
| (Some y1)as r1, ((Some y2) as r2) ->
if cmp y1 y2 <= 0
then (x1 := gen1 (); r1)
else (x2 := gen2 (); r2)
| (Some _)as r, None ->
x1 := gen1 ();
r
| None, ((Some _)as r) ->
x2 := gen2 ();
r
(*$T
sorted_merge (of_list [1;2;2;3;5;10;100]) (of_list [2;4;5;6;11]) \
|> to_list = [1;2;2;2;3;4;5;5;6;10;11;100]
*)
(** {4 Mutable heap (taken from heap.ml to avoid dependencies)} *)
module Heap = struct
type 'a t = {
mutable tree : 'a tree;
cmp : 'a -> 'a -> int;
} (** A pairing tree heap with the given comparison function *)
and 'a tree =
| Empty
| Node of 'a * 'a tree * 'a tree
let empty ~cmp = {
tree = Empty;
cmp;
}
let is_empty h =
match h.tree with
| Empty -> true
| Node _ -> false
let rec union ~cmp t1 t2 = match t1, t2 with
| Empty, _ -> t2
| _, Empty -> t1
| Node (x1, l1, r1), Node (x2, l2, r2) ->
if cmp x1 x2 <= 0
then Node (x1, union ~cmp t2 r1, l1)
else Node (x2, union ~cmp t1 r2, l2)
let insert h x =
h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree
let pop h = match h.tree with
| Empty -> raise Not_found
| Node (x, l, r) ->
h.tree <- union ~cmp:h.cmp l r;
x
end
let sorted_merge_n ?(cmp=Pervasives.compare) l =
(* make a heap of (value, generator) *)
let cmp (v1,_) (v2,_) = cmp v1 v2 in
let heap = Heap.empty ~cmp in
(* add initial values *)
List.iter
(fun gen' -> match gen'() with
| Some x -> Heap.insert heap (x, gen')
| None -> ())
l;
fun () ->
if Heap.is_empty heap then None
else begin
let x, gen = Heap.pop heap in
match gen() with
| Some y ->
Heap.insert heap (y, gen); (* insert next value *)
Some x
| None -> Some x (* gen empty, drop it *)
end
(*$T
sorted_merge_n [of_list [1;2;2;3;5;10;100]; of_list [2;4;5;6;11]; (6--10)] \
|> to_list = [1;2;2;2;3;4;5;5;6;6;7;8;9;10;10;11;100]
*)
let round_robin ?(n=2) gen =
(* array of queues, together with their index *)
let qs = Array.init n (fun i -> Queue.create ()) in
let cur = ref 0 in
(* get next element for the i-th queue *)
let rec next i =
let q = qs.(i) in
if Queue.is_empty q
then update_to_i i (* consume generator *)
else Some(Queue.pop q)
(* consume [gen] until some element for [i]-th generator is
available. *)
and update_to_i i =
match gen() with
| None -> None
| Some x ->
let j = !cur in
cur := (j+1) mod n; (* move cursor to next generator *)
let q = qs.(j) in
if j = i
then begin
assert (Queue.is_empty q);
Some x (* return the element *)
end else begin
Queue.push x q;
update_to_i i (* continue consuming [gen] *)
end
in
(* generators *)
let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in
Array.to_list l
(*$T
round_robin ~n:3 (1--12) |> List.map to_list = \
[[1;4;7;10]; [2;5;8;11]; [3;6;9;12]]
*)
(* Duplicate the enum into [n] generators (default 2). The generators
share the same underlying instance of the enum, so the optimal case is
when they are consumed evenly *)
let tee ?(n=2) gen =
(* array of queues, together with their index *)
let qs = Array.init n (fun i -> Queue.create ()) in
let finished = ref false in (* is [gen] exhausted? *)
(* get next element for the i-th queue *)
let rec next i =
if Queue.is_empty qs.(i)
then
if !finished then None
else get_next i (* consume generator *)
else Queue.pop qs.(i)
(* consume one more element *)
and get_next i = match gen() with
| (Some x) as res ->
for j = 0 to n-1 do
if j <> i then Queue.push res qs.(j)
done;
res
| None -> finished := true; None
in
(* generators *)
let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in
Array.to_list l
(*$T
tee ~n:3 (1--12) |> List.map to_list = \
[to_list (1--12); to_list (1--12); to_list (1--12)]
*)
module InterleaveState = struct
type 'a t =
| Only of 'a gen
| Both of 'a gen * 'a gen * bool ref
| Stop
end
(* Yield elements from a and b alternatively *)
let interleave gen_a gen_b =
let open InterleaveState in
let state = ref (Both (gen_a, gen_b, ref true)) in
let rec next() = match !state with
| Stop -> None
| Only g ->
begin match g() with
| None -> state := Stop; None
| (Some _) as res -> res
end
| Both (g1, g2, r) ->
match (if !r then g1() else g2()) with
| None ->
state := if !r then Only g2 else Only g1;
next()
| (Some _) as res ->
r := not !r; (* swap *)
res
in next
(*$T
interleave (repeat 0) (1--5) |> take 10 |> to_list = \
[0;1;0;2;0;3;0;4;0;5]
*)
module IntersperseState = struct
type 'a t =
| Start
| YieldElem of 'a option
| YieldSep of 'a option (* next val *)
| Stop
end
(* Put [x] between elements of [enum] *)
let intersperse x gen =
let open IntersperseState in
let state = ref Start in
let rec next() = match !state with
| Stop -> None
| YieldElem res ->
begin match gen() with
| None -> state := Stop
| Some _ as res' -> state := YieldSep res'
end;
res
| YieldSep res ->
state := YieldElem res;
Some x
| Start ->
match gen() with
| None -> state := Stop; None
| Some _ as res -> state := YieldElem res; next()
in next
(*$T
intersperse 0 (1--5) |> to_list = [1;0;2;0;3;0;4;0;5]
*)
(* Cartesian product *)
let product gena genb =
let all_a = ref [] in
let all_b = ref [] in
(* cur: current state, i.e., what we have to do next. Can be stop,
getLeft/getRight (to obtain next element from first/second generator),
or prodLeft/prodRIght to compute the product of an element with a list
of already met elements *)
let cur = ref `GetLeft in
let rec next () =
match !cur with
| `Stop -> None
| `GetLeft ->
begin match gena() with
| None -> cur := `GetRightOrStop
| Some a -> all_a := a :: !all_a; cur := `ProdLeft (a, !all_b)
end;
next ()
| `GetRight | `GetRightOrStop -> (* TODO: test *)
begin match genb() with
| None when !cur = `GetRightOrStop -> cur := `Stop
| None -> cur := `GetLeft
| Some b -> all_b := b::!all_b; cur := `ProdRight (b, !all_a)
end;
next ()
| `ProdLeft (_, []) ->
cur := `GetRight;
next()
| `ProdLeft (x, y::l) ->
cur := `ProdLeft (x, l);
Some (x, y)
| `ProdRight (_, []) ->
cur := `GetLeft;
next()
| `ProdRight (y, x::l) ->
cur := `ProdRight (y, l);
Some (x, y)
in
next
(*$T
product (1--3) (of_list ["a"; "b"]) |> to_list \
|> List.sort Pervasives.compare = \
[1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b"]
*)
(* Group equal consecutive elements together. *)
let group ?(eq=(=)) gen =
match gen() with
| None -> fun () -> None
| Some x ->
let cur = ref [x] in
let rec next () =
(* try to get an element *)
let next_x = if !cur = [] then None else gen() in
match next_x, !cur with
| None, [] -> None
| None, l ->
cur := []; (* stop *)
Some l
| Some x, y::_ when eq x y ->
cur := x::!cur;
next () (* same group *)
| Some x, l ->
cur := [x];
Some l
in next
(*$T
group (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \
[[0;0;0];[1];[0];[2;2];[3];[4];[5;5;5;5];[10]]
*)
let uniq ?(eq=(=)) gen =
let state = ref Init in
let rec next() = match !state with
| Stop -> None
| Init ->
begin match gen() with
| None -> state:= Stop; None
| (Some x) as res -> state := Run x; res
end
| Run x ->
begin match gen() with
| None -> state:= Stop; None
| (Some y) as res ->
if eq x y
then next() (* ignore duplicate *)
else (state := Run y; res)
end
in next
(*$T
uniq (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \
[0;1;0;2;3;4;5;10]
*)
let sort ?(cmp=Pervasives.compare) gen =
(* build heap *)
let h = Heap.empty ~cmp in
iter (Heap.insert h) gen;
fun () ->
if Heap.is_empty h
then None
else Some (Heap.pop h)
(*$T
sort (of_list [0;0;0;1;0;2;2;3;4;5;5;5;-42;5;10]) |> to_list = \
[-42;0;0;0;0;1;2;2;3;4;5;5;5;5;10]
*)
(* NOTE: using a set is not really possible, because once we have built the
set there is no simple way to iterate on it *)
let sort_uniq ?(cmp=Pervasives.compare) gen =
uniq ~eq:(fun x y -> cmp x y = 0) (sort ~cmp gen)
(*$T
sort_uniq (of_list [0;0;0;1;0;2;2;3;4;5;42;5;5;42;5;10]) |> to_list = \
[0;1;2;3;4;5;10;42]
*)
let chunks n e =
let rec next () =
match e() with
| None -> None
| Some x ->
let a = Array.make n x in
fill a 1
and fill a i =
(* fill the array. [i]: current index to fill *)
if i = n
then Some a
else match e() with
| None -> Some (Array.sub a 0 i) (* last array is not full *)
| Some x ->
a.(i) <- x;
fill a (i+1)
in
next
(*$T
chunks 25 (0--100) |> map Array.to_list |> to_list = \
List.map to_list [(0--24); (25--49);(50--74);(75--99);(100--100)]
*)
(*
let permutations enum =
failwith "not implemented" (* TODO *)
let combinations n enum =
assert (n >= 0);
failwith "not implemented" (* TODO *)
let powerSet enum =
failwith "not implemented"
*)
(** {3 Conversion} *)
let of_list l =
let l = ref l in
fun () ->
match !l with
| [] -> None
| x::l' -> l := l'; Some x
let to_rev_list gen =
fold (fun acc x -> x :: acc) [] gen
(*$Q
(Q.list Q.small_int) (fun l -> \
to_rev_list (of_list l) = List.rev l)
*)
let to_list gen = List.rev (to_rev_list gen)
let to_array gen =
let l = to_rev_list gen in
match l with
| [] -> [| |]
| _ ->
let a = Array.of_list l in
let n = Array.length a in
(* reverse array *)
for i = 0 to (n-1) / 2 do
let tmp = a.(i) in
a.(i) <- a.(n-i-1);
a.(n-i-1) <- tmp
done;
a
let of_array ?(start=0) ?len a =
let len = match len with
| None -> Array.length a - start
| Some n -> assert (n + start < Array.length a); n in
let i = ref start in
fun () ->
if !i >= start + len
then None
else (let x = a.(!i) in incr i; Some x)
(*$Q
(Q.array Q.small_int) (fun a -> \
of_array a |> to_array = a)
*)
let rand_int i =
repeatedly (fun () -> Random.int i)
let int_range i j =
let r = ref i in
fun () ->
let x = !r in
if x > j then None
else begin
incr r;
Some x
end
let pp ?(start="") ?(stop="") ?(sep=",") ?(horizontal=false) pp_elem formatter gen =
(if horizontal
then Format.pp_open_hbox formatter ()
else Format.pp_open_hvbox formatter 0);
Format.pp_print_string formatter start;
let rec next is_first =
match gen() with
| Some x ->
if not is_first
then begin
Format.pp_print_string formatter sep;
Format.pp_print_space formatter ();
pp_elem formatter x
end else pp_elem formatter x;
next false
| None -> ()
in
next true;
Format.pp_print_string formatter stop;
Format.pp_close_box formatter ()
module Infix = struct
let (--) = int_range
let (>>=) x f = flat_map f x
end
include Infix
module Restart = struct
type 'a t = unit -> 'a gen
type 'a restartable = 'a t
let lift f e = f (e ())
let lift2 f e1 e2 = f (e1 ()) (e2 ())
let empty () = empty
let singleton x () = singleton x
let iterate x f () = iterate x f
let repeat x () = repeat x
let unfold f acc () = unfold f acc
let init ?limit f () = init ?limit f
let cycle enum =
assert (not (is_empty (enum ())));
fun () ->
let gen = ref (enum ()) in (* start cycle *)
let rec next () =
match (!gen) () with
| (Some _) as res -> res
| None -> gen := enum(); next()
in next
let is_empty e = is_empty (e ())
let fold f acc e = fold f acc (e ())
let reduce f e = reduce f (e ())
let scan f acc e () = scan f acc (e ())
let iter f e = iter f (e ())
let iteri f e = iteri f (e ())
let length e = length (e ())
let map f e () = map f (e ())
let append e1 e2 () = append (e1 ()) (e2 ())
let flatten e () = flatten (e ())
let flat_map f e () = flat_map f (e ())
let mem ?eq x e = mem ?eq x (e ())
let take n e () = take n (e ())
let drop n e () = drop n (e ())
let nth n e = nth n (e ())
let take_nth n e () = take_nth n (e ())
let filter p e () = filter p (e ())
let take_while p e () = take_while p (e ())
let drop_while p e () = drop_while p (e ())
let filter_map f e () = filter_map f (e ())
let zip_with f e1 e2 () = zip_with f (e1 ()) (e2 ())
let zip e1 e2 () = zip (e1 ()) (e2 ())
let zip_index e () = zip_index (e ())
let unzip e = map fst e, map snd e
let partition p e =
filter p e, filter (fun x -> not (p x)) e
let for_all p e =
for_all p (e ())
let exists p e =
exists p (e ())
let for_all2 p e1 e2 =
for_all2 p (e1 ()) (e2 ())
let exists2 p e1 e2 =
exists2 p (e1 ()) (e2 ())
let map2 f e1 e2 () =
map2 f (e1()) (e2())
let iter2 f e1 e2 =
iter2 f (e1()) (e2())
let fold2 f acc e1 e2 =
fold2 f acc (e1()) (e2())
let min ?lt e = min ?lt (e ())
let max ?lt e = max ?lt (e ())
let ___eq = eq
let eq ?eq e1 e2 = ___eq ?eq (e1 ()) (e2 ())
let lexico ?cmp e1 e2 = lexico ?cmp (e1 ()) (e2 ())
let compare ?cmp e1 e2 = compare ?cmp (e1 ()) (e2 ())
let sum e = sum (e())
let find f e = find f (e())
let merge e () = merge (e ())
let intersection ?cmp e1 e2 () =
intersection ?cmp (e1 ()) (e2 ())
let sorted_merge ?cmp e1 e2 () =
sorted_merge ?cmp (e1 ()) (e2 ())
let sorted_merge_n ?cmp l () =
sorted_merge_n ?cmp (List.map (fun g -> g()) l)
let tee ?n e = tee ?n (e ())
let round_robin ?n e = round_robin ?n (e ())
let interleave e1 e2 () = interleave (e1 ()) (e2 ())
let intersperse x e () = intersperse x (e ())
let product e1 e2 () = product (e1 ()) (e2 ())
let group ?eq e () = group ?eq (e ())
let uniq ?eq e () = uniq ?eq (e ())
let sort ?(cmp=Pervasives.compare) enum =
fun () -> sort ~cmp (enum ())
let sort_uniq ?(cmp=Pervasives.compare) e =
let e' = sort ~cmp e in
uniq ~eq:(fun x y -> cmp x y = 0) e'
let chunks n e () = chunks n (e())
let of_list l () = of_list l
let to_rev_list e = to_rev_list (e ())
let to_list e = to_list (e ())
let to_array e = to_array (e ())
let of_array ?start ?len a () = of_array ?start ?len a
let rand_int i () = rand_int i
let int_range i j () = int_range i j
module Infix = struct
let (--) = int_range
let (>>=) x f = flat_map f x
end
include Infix
let pp ?start ?stop ?sep ?horizontal pp_elem fmt e =
pp ?start ?stop ?sep ?horizontal pp_elem fmt (e ())
end
(** {2 Generator functions} *)
let start g = g ()
(** {6 Unrolled mutable list} *)
module MList = struct
type 'a node =
| Nil
| Cons of 'a array * int ref * 'a node ref
let of_gen gen =
let start = ref Nil in
let chunk_size = ref 8 in
(* fill the list. prev: tail-reference from previous node,
* cur: current list node *)
let rec fill prev cur =
match cur, gen() with
| _, None -> prev := cur; () (* done *)
| Nil, Some x ->
let n = !chunk_size in
if n < 4096 then chunk_size := 2 * !chunk_size;
fill prev (Cons (Array.make n x, ref 1, ref Nil))
| Cons (a, n, next), Some x ->
assert (!n < Array.length a);
a.(!n) <- x;
incr n;
if !n = Array.length a
then begin
prev := cur;
fill next Nil
end else fill prev cur
in
fill start !start ;
!start
let to_gen l () =
let cur = ref l in
let i = ref 0 in
let rec next() = match !cur with
| Nil -> None
| Cons (a,n,l') ->
if !i = !n
then begin
cur := !l';
i := 0;
next()
end else begin
let y = a.(!i) in
incr i;
Some y
end
in
next
end
(** Store content of the generator in an enum *)
let persistent gen =
let l = MList.of_gen gen in
MList.to_gen l
(*$T
let g = 1--10 in let g' = persistent g in \
Restart.to_list g' = Restart.to_list g'
let g = 1--10 in let g' = persistent g in \
Restart.to_list g' = [1;2;3;4;5;6;7;8;9;10]
*)