(* 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] *)