1 (* This version from 1 April 2015 *)
3 module Juli8 = struct
5 (*
6   module Std = struct
7     include Pervasives
8     module List = List
9   end
10 *)
12   external ident : 'a -> 'a = "%identity"
13   let const c = (); fun _ -> c
14   (* TODO: include fun x y -> f (g x y)? include flip (%)? *)
15   let (%) f g = (); fun x -> f (g x)
16   let flip f = (); fun x y -> f y x
17   let fix (f : ('a -> 'b) -> ('a -> 'b)) : 'a -> 'b = let rec x y = f x y in x
19   (* Haskell's `(op rightval)` = `flip (op) rightval` *)
20   (* Haskell's `f \$ xxx \$ yyy` == `f @@ xxx @@ yyy` which is properly right-associative.
21      If you `let (\$\$) = (@@)`, then `f \$\$ xxx \$\$ yyy` will be `f (xxx) (yyy)`. *)
23   (* `non p` == `not % p` *)
24   let non f = (); fun x -> not (f x)
25   let non2 f = (); fun x y -> not (f x y)
27   let pair x y = (x, y)
28   let swap (x, y) = (y, x)
29   let curry f = (); fun x y -> f (x, y)
30   let uncurry f = (); fun (x, y) -> f x y
31   let mapfst f (x, y) = (f x, y)
32   let mapsnd f (x, y) = (x, f y)
34   let even x = x land 1 = 0
35   let odd x = x land 1 = 1
36   let sign x = if x < 0 then -1 else if x > 0 then 1 else 0
37   exception Overflow
38   let pred x = if x < 0 then invalid_arg "pred" else if x > 0 then x - 1 else raise Overflow
39   let pred' x = if x < 0 then invalid_arg "pred'" else if x > 0 then x - 1 else 0
40   let sub x y = if x < 0 || y < 0 then invalid_arg "sub" else if x >= y then x - y else raise Overflow
41   let sub' x y = if x < 0 || y < 0 then invalid_arg "sub'" else if x >= y then x - y else 0
42   let mid x y = x land y + ((x lxor y) asr 1)
43   let pow (x : int) (n : int) : int =
44     let rec aux x n =
45       if n = 1 then x
46       else
47         let y = aux x (n asr 1) in
48         y * y * (if n land 1 = 0 then 1 else x) in
49     if n < 0 then invalid_arg "pow"
50     else if n = 0 then 1
51     else aux x n
53   let undefined () = failwith "undefined"
55   let finally handler f x =
56     let res = (try f x with e -> handler(); raise e) in
57     handler(); res
59   (* Haskell's `last \$ take n \$ iterate s z`, might also call `ntimes` *)
60   let rec iterate (n : int) s z =
61     if n <= 0 then z
62     else iterate (n - 1) s (s z)
64   (* Haskell's `head \$ dropWhile p \$ iterate s z`; or `until (not.p) s z` *)
65   let rec iter_while p s z =
66     if p z then iter_while p s (s z) else z
68   (* let forever f x = while true do f x done *)
69   let rec forever f x = ignore(f x); forever f x
71   module Option : sig
72     val some : 'a -> 'a option
73     val test : ('a -> bool) -> 'a -> 'a option
74     val is_some : 'a option -> bool
75     val is_none : 'a option -> bool
76     val unsome : exn -> 'a option -> 'a (* Haskell's `fromJust` *)
77     val optcatch : ('a -> 'b) -> 'a -> 'b option
78     val string_of_option : ('a -> string) -> 'a option -> string
79     val list_of_option : 'a option -> 'a list (* Haskell's `maybeToList` *)
81     val default : 'a -> 'a option -> 'a (* Haskell's `fromMaybe` *)
82     val mapdefault : 'b -> ('a -> 'b) -> 'a option -> 'b (* Haskell's `maybe` *)
83     (* List.optmap is Haskell's `mapMaybe` *)
84     val length : 'a option -> int
85     val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a option -> bool
86     val map : ('a -> 'b) -> 'a option -> 'b option
87     val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option
88     val filter : ('a -> bool) -> 'a option -> 'a option
89   end = struct
90     let some x = Some x
91     let test p x = if p x then Some x else None
92     let is_some = function Some _ -> true | _ -> false
93     let is_none = function None -> true | _ -> false
94     let unsome exn = function Some a -> a | None -> raise exn
95     let optcatch f a = try Some (f a) with _ -> None
96     let string_of_option f = function Some a -> "Some " ^ f a | None -> "None"
97     let list_of_option = function Some a -> [a] | None -> []
98     let default def = function Some a -> a | None -> def
99     let mapdefault def f = function Some a -> f a | None -> def
100     let length = function Some _ -> 1 | None -> 0
101     let mem ?(eq=(=)) sought = function Some y -> eq y sought | None -> false
102     let map f = function Some a -> Some (f a) | None -> None
103     let map2 f u v = match u,v with Some x,Some y -> Some (f x y) | _ -> None
104     let filter p = function Some a as orig when p a -> orig | _ -> None
105   end
107   let some = Option.some
108   let is_some = Option.is_some
109   let is_none = Option.is_none
110   let unsome = Option.unsome
111   let string_of_option = Option.string_of_option
112   let list_of_option = Option.list_of_option
114   module List : sig
115     (*
116        Some functions in this module accept labels: ~short, ~onto:_, ~rev, ~cmp:_, ~eq:_, ~missing:_, ~step:_, ~many, ~len:_.
117        ~short (map2, zip, iter2, fold_left2, fold_right2) means you don't require the lists to be the same length. (NOT provided for for_all2, exists2)
118        ~onto:[] is for efficiency (rev, map, mapi, map2, zip, unmap2, unzip, optmap, optmapi, catmap, catmapi, filter, unfold, mapz).
119        ~rev sometimes (map, optmap, catmap, map2, zip, unmap2, unzip, filter, unfold, mapz) means you don't require the output to correspond to input order, and thus can get more efficient implementation.
120        For sort and is_sorted, ~rev reverses the direction of ~cmp (first match will still come first/be retained if not ~many).
121        ~rev other times (max/minimum, max/minby, take_while, drop_while, split_while, find[x], optfind, index, remove, delete, pick[x], assoc/assq, [opt]modify_assoc/assq, remove_assoc/assq) means find last match rather than first.
122        Find/remove from end: find[x]/optfind/index ~rev, remove/delete ~rev, pick[x] ~rev; also assoc/assq, [opt]modify_assoc/assq, remove_assoc/assq.
123        Find/remove all: filter[x]/indices, remove/delete ~many, partition[x]. (`remove ~many` is `filter (non p)`); also remove_assoc/assq ~many and diff ~many.
124        These have a default ~cmp: max/minimum, max/minby, lexcmp, sort, is_sorted, insert, merge (the latter two assume ordered lists). Other times (mem, index, delete, [is_]unique, is_subset, diff, union, intersect) ~cmp:_ asserts the list is ordered, and ignores any ~eq specification.
125        Functions seeking a specific member/key may specify the ~eq:(=) function (mem, index, delete, indices, assoc, mem_assoc, [opt]modify_assoc, remove_assoc).
126        Other functions using ~eq: group, [is_]unique, is_eqset, is_subset/list, diff, union, intersect, histogram.
127        See also memq, indexq, deleteq, indicesq, assq, mem_assq, [opt]modify_assq, remove_assq.
128        Additionally, modify_assoc/assq accepts an optional ~missing:(fun k -> v) alongside its (fun k v -> v); else it raises Not_found. pairwise accepts optional ~missing:'a to supply a snd for the last element.
129        Additionally, range and range_until accept ~step, and range's second argument can be tagged ~len.
130        Additionally, insert and sort accept an optional ~many to insert/keep items even if they cmp 0 to existing members. is_sorted ~many interprets "sorted" to permit duplicates; and is_subset ~many permits multiplicity of subset to > super. See also remove/delete ~many and remove_assoc/assq ~many and diff ~many.
131        sublists and permutations accept optional ~len, and can also be invoked as ~len:_ ~many to mean with replacement.
133        Functions in this module may raise:
134        * Invalid_argument for indices < 0, or length < 0 for make, or ~step:0 for range/_until
135        * Invalid argument when specifying both ~cmp and ~rev to index, delete; or both ~many and ~rev to remove, delete.
136        * Invalid_argument when is_subset without ~cmp or ~many; or when sublists/permutations ~many without ~len
137        * Not_found
138        * Short_list, e.g. head []; map2 f [] [...] without ~short; indices >= length
139        Primed versions of tail, init, take, drop, split: silently accommodate short lists. (Compare pred', sub'.)
140     *)
142     (* TODO: cycle n xs *)
143     (* IFFY names: unmap2, mapz, min/maxby, chunk[']/chunk_int/chunk_range, is_eqset, indexq/indicesq/deleteq *)
145     val short : unit
146     val many : unit
147     exception Short_list
148     val is_null : 'a list -> bool
149     val length : 'a list -> int
150     val count : ('a -> bool) -> 'a list -> int
151     val cons : 'a -> 'a list -> 'a list
152     val snoc : 'a list -> 'a -> 'a list
153     val singleton : 'a -> 'a list
154     val make : int -> 'a -> 'a list (* Haskell's `replicate` *)
155     val head : 'a list -> 'a
156     val opthead : 'a list -> 'a option
157     val tail : 'a list -> 'a list
158     val tail' : 'a list -> 'a list
159     val uncons : 'a list -> 'a * 'a list
160     val last : 'a list -> 'a
161     val init : 'a list -> 'a list
162     val init' : 'a list -> 'a list
163     val append : 'a list -> 'a list -> 'a list
164     val concat : 'a list list -> 'a list
165     val rev : ?onto:'a list -> 'a list -> 'a list (* Haskell's `reverse` *)
166     val mem : 'a -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> bool (* Haskell's `elem` *)
167     val map : ('a -> 'b) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list
168     val map2 : ('a -> 'b -> 'c) -> ?rev:'d -> ?onto:'c list -> ?short:'e -> 'a list -> 'b list -> 'c list (* Haskell's `zipWith` *)
169     val unmap2 : ('c -> 'a * 'b) -> ?rev:'d -> ?onto:'a list * 'b list -> 'c list -> 'a list * 'b list
170     val zip : ?rev:'d -> ?onto:('a * 'b) list -> ?short:'e -> 'a list -> 'b list -> ('a * 'b) list (* aka `Std.List.combine` or `map2 pair` *)
171     val unzip : ?rev:'d -> ?onto:'b list * 'c list -> ('b * 'c) list -> 'b list * 'c list (* aka `Std.List.split` or `unmap2 ident` *)
172     val mapi : (int -> 'a -> 'b) -> ?onto:'b list -> 'a list -> 'b list
173     val optmap : ('a -> 'b option) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list
174     val optmapi : (int -> 'a -> 'b option) -> ?onto:'b list -> 'a list -> 'b list
175     (* `catmap f ~rev [x1,x2,x3]` ==> [x3c..x3a; x2c..x2a; x1c..x1a] *)
176     val catmap : ('a -> 'b list) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list (* Haskell's `concatMap` *)
177     val catmapi : (int -> 'a -> 'b list) -> ?onto:'b list -> 'a list -> 'b list
178     val iter : ('a -> unit) -> 'a list -> unit
179     val iteri : (int -> 'a -> unit) -> 'a list -> unit
180     val iter2 : ('a -> 'b -> unit) -> ?short:'c -> 'a list -> 'b list -> unit
181     val fold_left : ('z -> 'a -> 'z) -> 'z -> 'a list -> 'z
182     val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a
183     val fold_left2 : ('z -> 'a -> 'b -> 'z) -> 'z -> ?short:'d -> 'a list -> 'b list -> 'z
184     val fold_right : ('a -> 'z -> 'z) -> 'a list -> 'z -> 'z
185     val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a
186     val fold_right2 : ('a -> 'b -> 'z -> 'z) -> ?short:'d -> 'a list -> 'b list -> 'z -> 'z
187     val for_all : ('a -> bool) -> 'a list -> bool (* Haskell's `all` *)
188     val exists : ('a -> bool) -> 'a list -> bool (* Haskell's `any` *)
189     val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
190     val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
191     val maximum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a
192     val minimum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a
193     (* These compare mapped values, and return index,original,mapped value. *)
194     val maxby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b
195     val minby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b
196     val sum : int list -> int
197     val product : int list -> int
198     val take : int -> 'a list -> 'a list
199     val take' : int -> 'a list -> 'a list
200     val drop : int -> 'a list -> 'a list (* `tail` is `drop 1` *)
201     val drop' : int -> 'a list -> 'a list
202     val split : int -> 'a list -> 'a list * 'a list
203     val split' : int -> 'a list -> 'a list * 'a list (* Haskell's `splitAt` *)
204     val nth : 'a list -> int -> 'a (* Haskell's `xs !! n` *)
205     val modify : int -> ('a -> 'a) -> 'a list -> 'a list
206     val optmodify : int -> ('a -> 'a option) -> 'a list -> 'a list
207     val catmodify : int -> ('a -> 'a list) -> 'a list -> 'a list
208     val take_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list
209     val drop_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list
210     (* `split_while p xs` is `(take_while p xs, drop_while p xs)`; but `split_while p ~rev xs` is `(drop_while p ~rev xs, take_while p ~rev xs)` *)
211     val split_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list * 'a list (* Haskell's `span` *)
212     val find : ('a -> bool) -> ?rev:'b -> 'a list -> 'a
213     val optfind : ('a -> 'b option) -> ?rev:'c -> 'a list -> 'b
214     val findx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a (* fst of this is Haskell's `findIndex`, except that returns Maybe Int *)
215     (* Unlike findx, index accepts ~cmp. *)
216     val index : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> int (* Haskell's `elemIndex`, except that returns Maybe Int *)
217     val remove : ('a -> bool) -> ?rev:'b -> ?many:'c -> 'a list -> 'a list
218     val delete : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> ?many:'c -> 'a list -> 'a list
219     (* `pick p xs` is `(find p xs, remove p xs)` *)
220     val pick : ('a -> bool) -> ?rev:'b -> 'a list -> 'a * 'a list
221     val pickx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a * 'a list
222     val filter : ('a -> bool) -> ?rev:'b -> ?onto:'a list -> 'a list -> 'a list
223     val filterx : ('a -> bool) -> 'a list -> (int * 'a) list (* fst of this is Haskell's `findIndices` *)
224     val indices : 'a -> ?eq:('a -> 'a -> bool) -> 'a list -> int list (* Haskell's `elemIndices` *)
225     (* `partition p xs` is `(filter p xs, filter (non p) xs)` *)
226     val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
227     val partitionx : ('a -> bool) -> 'a list -> (int * 'a) list * (int * 'a) list
228     val assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> 'b (* Haskell's `lookup` *)
229     val mem_assoc : 'a -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> bool
230     val modify_assoc : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list
231     val optmodify_assoc : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list
232     val remove_assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list
233     val memq : 'a -> 'a list -> bool
234     val indexq : 'a -> 'a list -> int
235     val deleteq : 'a -> 'a list -> 'a list
236     val indicesq : 'a -> 'a list -> int list
237     val assq : 'a -> ?rev:'c -> ('a * 'b) list -> 'b
238     val mem_assq : 'a -> ('a * 'b) list -> bool
239     val modify_assq : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list
240     val optmodify_assq : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list
241     val remove_assq : 'a -> ?rev:'c -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list
243     (* Positive n rotates forward; `rotate 1 xs` is `append (last xs) (init xs)` or `unsnoc` *)
244     val rotate : int -> 'a list -> 'a list
245     val unfold : ('z -> ('a * 'z) option) -> ?rev:'c -> ?onto:'a list -> 'z -> 'a list
246     (* ~rev only affects the order of the mapz'd output, not the direction of the folding *)
247     val mapz : ('z -> 'a -> 'z * 'b) -> 'z -> ?rev:'d -> ?onto:'b list -> 'a list -> 'z * 'b list (* Haskell's `mapAccumL` *)
248     val group : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list list (* Haskell's `groupBy` *)
249     (* `cross f xs ys` is `[f x y | x from xs, y from ys]` or `catmap (fun x -> map (f x) ys) xs` *)
250     val cross : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
251     (* `insert` expects a sorted list; use `catmodify` to insert elements before/after a specified index *)
252     val insert : 'a -> ?cmp:('a -> 'a -> int) -> ?many:'b -> 'a list -> 'a list
253     (* Plural version of `nth` *)
254     val select : 'a list -> int list -> 'a list
255     (* `range start ~len` *)
256     val range : ?step:int -> int -> len:int -> int list
257     (* `range_until start excluded_stop`; specify ~step:1 to produce [] when stop < start *)
258     val range_until : ?step:int -> int -> int -> int list
259     val unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list (* Haskell's `nub` *)
260     val is_unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> bool
261     (* `transpose [xxx, yyy]` ==> [xy, xy, xy] *)
262     val transpose : 'a list list -> 'a list list
264        Permutations with replacement, or enum base xs of 0..pow (length xs) k-1, is Haskell's `replicateM k xs` or `sequence \$ replicate k xs`; same as `cross klist (make k xs)` *)
265     val permutations : ?len:int -> ?many:'b -> 'a list -> 'a list list
266     (* `sublists` without ~len or ~many is powerlist/all combinations, preserving order of members, who needn't have been contiguous; is Haskell's `subsequences` or `filterM (const [False, True]) xs`.
267        sublists ~len:k gives combinations of length k; straightforward implementation, found at http://www.polyomino.f2s.com/david/haskell/hs/CombinatoricsGeneration.hs.txt, also http://rosettacode.org/wiki/Combinations#Haskell
268        sublists ~len:k ~many gives the ((length xs+k-1) choose k) many combinations with replacement; based on http://rosettacode.org/wiki/Combinations_with_repetitions#Haskell *)
269     val sublists : ?len:int -> ?many:'b -> 'a list -> 'a list list
270     (* Members of first arg must appear in order in second, though they needn't be contiguous; for sorted lists, is a less-efficient version of `is_subset` without ~many *)
271     val is_sublist : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool
272     (* `let sup =  in is_subset ~many [1;1] sup` is true; omit ~many to require sup to have >= the multiplicity of each member of subset *)
273     val is_subset : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> bool
274     (* Multiset equality, order ignored *)
275     val is_eqset : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool
276     val lexcmp : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
277     (* `diff ~many xs ys` deletes all occurrences of each member of ys *)
278     val diff : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> 'a list
279     (* Each element has its max multiplicity; with second list always as a suffix of the result *)
280     val union : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
281     (* Each element has its min multiplicity; in order of second list *)
282     val intersect : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
283     (* To merge without ~many, use `union ~cmp:compare`. *)
284     val merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
285     (* Stable mergesort, O(n log n) avg and worst, will delete later occurrences of any duplicates, unless invoked with ~many *)
286     val sort : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> 'a list
287     val is_sorted : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> bool
288     val string_of_list : ?brackets:bool -> ?sep:string -> ('a -> string) -> 'a list -> string
289     val histogram : ?eq:('a -> 'a -> bool) -> 'a list -> ('a * int) list
290     (* [x1;x2;x3] ==> [(x1,x2);(x2,x3);(x3,missing)] *)
291     val pairwise : ?missing:'a -> 'a list -> ('a * 'a) list
292     (* [xxxx,y,zz] ==> xyzxzxx *)
293     val round_robin : 'a list list -> 'a list
294     (* Break list into int-sized discrete segments; chunk' permits last chunk to be short *)
295     val chunk : int -> 'a list -> 'a list list
296     val chunk' : int -> 'a list -> 'a list list
297     (* How many ways can int be represented as sum of members of xs (permitting them to be re-used)?
298        `chunk_int 6 [1;2;3]` ==> [ [3;3]; [3;2;1]; [3;1;1;1]; ...]
299        These are sometimes called "partitions of N". Based on http://www.polyomino.f2s.com/david/haskell/hs/CombinatoricsGeneration.hs.txt. This is an NP problem. *)
300     val chunk_int : int -> int list -> int list list
301     (* Partitions of the range 0..(k1+k2+k3) into lists of size k1,k2,k3.
302        `chunk_range [2;1;3]` ==> [ [[0;1];;[3;4;5]]; ...]
304     val chunk_range : int list -> int list list list
306   end = struct
308     let short = ()
309     let many = ()
310     exception Short_list
312     let is_null = function [] -> true | _ -> false
314     let length xs =
315       let rec aux i = function [] -> i | _::xs -> aux (i+1) xs in
316       aux 0 xs
318     let count p xs =
319       let rec aux p n = function [] -> n | x::xs when p x -> aux p (n+1) xs | _::xs -> aux p n xs in
320       aux p 0 xs
322     let cons x xs = x :: xs
324     let singleton x = [x]
326     let make n x =
327       let rec aux x xs n = if n = 0 then xs else aux x (x::xs) (n-1) in
328     if n < 0 then invalid_arg "make" else aux x [] n
330     let rec rev1 onto = function [] -> onto | x::xs -> rev1 (x::onto) xs
332     let rec rev2 onto = function [] -> onto | ys::yss -> rev2 (rev1 onto ys) yss
334     let rec rev ?(onto=[]) = function [] -> onto | x::xs -> let onto = x::onto in rev ~onto xs
336     let snoc xs x = rev1 [x] (rev1 [] xs)
338     let head = function x::_ -> x | [] -> raise Short_list
340     let opthead = function x::_ -> Some x | [] -> None
342     let tail = function _::xs -> xs | [] -> raise Short_list
344     let tail' = function _::xs -> xs | [] -> []
346     let uncons = function x::xs -> (x,xs) | [] -> raise Short_list
348     let rec last = function [x] -> x | x::xs -> last xs | _ -> raise Short_list
350     let init xs = match rev1 [] xs with [] -> raise Short_list | _::xs -> rev1 [] xs
352     let init' xs = match rev1 [] xs with [] -> [] | _::xs -> rev1 [] xs
354     let append xs = function [] -> xs | onto -> rev1 onto (rev1 [] xs)
356     let concat xss = rev2 [] (rev1 [] xss)
358     let mem sought ?(eq=(=)) ?cmp xs =
359       let rec aux_all eq sought = function [] -> false | x::xs -> eq x sought || aux_all eq sought xs in
360       let rec aux_sorted cmp sought = function
361       | x::xs -> let res = cmp x sought in if res > 0 then false else res = 0 || aux_sorted cmp sought xs
362       | [] -> false in
363       match cmp with
364       | None -> aux_all eq sought xs
365       | Some cmp -> aux_sorted cmp sought xs
367     let rec memq sought = function [] -> false | x::xs -> x == sought || memq sought xs
369     let map f ?rev ?(onto=[]) xs =
370       let rec aux f onto = function
371       | [] -> onto
372       | x::xs -> aux f (f x::onto) xs in
373       match rev with
374       | None -> rev1 onto (aux f [] xs)
375       | Some _ -> aux f onto xs
377     let map2 f ?rev ?(onto=[]) ?short xs ys =
378       let rec aux f short onto xs ys = match xs, ys with
379       | x::xs, y::ys -> aux f short (f x y::onto) xs ys
380       | [],[] -> onto
381       | _ -> if short then onto else raise Short_list in
382       match rev with
383       | None -> rev1 onto (aux f (Option.is_some short) [] xs ys)
384       | Some _ -> aux f (Option.is_some short) onto xs ys
386     let zip ?rev ?(onto=[]) ?short xs ys =
387       let rec aux short onto xs ys = match xs, ys with
388       | x::xs, y::ys -> aux short ((x,y)::onto) xs ys
389       | [],[] -> onto
390       | _ -> if short then onto else raise Short_list in
391       match rev with
392       | None -> rev1 onto (aux (Option.is_some short) [] xs ys)
393       | Some _ -> aux (Option.is_some short) onto xs ys
395     let unmap2 f ?rev ?(onto=[],[]) zs =
396       let rec aux f xs ys = function
397       | [] -> xs, ys
398       | z::zs -> let x,y = f z in aux f (x::xs) (y::ys) zs in
399       match rev,onto with
400       | None,(xonto,yonto) -> let xs,ys = aux f [] [] zs in rev1 xonto xs, rev1 yonto ys
401       | Some _,(xonto,yonto) -> aux f xonto yonto zs
403     let unzip ?rev ?(onto=[],[]) zs =
404       let rec aux xs ys = function
405       | [] -> xs, ys
406       | (x,y)::zs -> aux (x::xs) (y::ys) zs in
407       match rev,onto with
408       | None,(xonto,yonto) -> let xs,ys = aux [] [] zs in rev1 xonto xs, rev1 yonto ys
409       | Some _,(xonto,yonto) -> aux xonto yonto zs
411     let mapi f ?(onto=[]) xs =
412       let rec aux f i onto = function
413       | [] -> onto
414       | x::xs -> aux f (i+1) (f i x::onto) xs in
415       rev1 onto (aux f 0 [] xs)
417     let optmap f ?rev ?(onto=[]) xs =
418       let rec aux f onto = function
419       | [] -> onto
420       | x::xs -> aux f (match f x with None -> onto | Some x' -> x'::onto) xs in
421       match rev with
422       | None -> rev1 onto (aux f [] xs)
423       | Some _ -> aux f onto xs
425     let optmapi f ?(onto=[]) xs =
426       let rec aux f i onto = function
427       | [] -> onto
428       | x::xs -> aux f (i+1) (match f i x with None -> onto | Some x' -> x'::onto) xs in
429       rev1 onto (aux f 0 [] xs)
431     let catmap f ?rev ?(onto=[]) xs =
432       let rec aux f onto = function
433       | [] -> onto
434       | x::xs -> aux f (rev1 [] (f x)::onto) xs in
435       let rec aux_rev f onto = function
436       | [] -> onto
437       | x::xs -> aux_rev f (rev1 onto (f x)) xs in
438       match rev with
439       | None -> rev2 onto (aux f [] xs)
440       | Some _ -> aux_rev f onto xs
442     let catmapi f ?(onto=[]) xs =
443       let rec aux f i onto = function
444       | [] -> onto
445       | x::xs -> aux f (i+1) (rev1 [] (f i x)::onto) xs in
446       rev2 onto (aux f 0 [] xs)
448     let rec iter f = function [] -> () | x::xs -> f x; iter f xs
450     let iteri f xs =
451       let rec aux f i = function [] -> () | x::xs -> f i x; aux f (i+1) xs in
452       aux f 0 xs
454     let iter2 f ?short xs ys =
455       let rec aux f short xs ys = match xs, ys with
456       | x::xs, y::ys -> f x y; aux f short xs ys
457       | [],[] -> ()
458       | _ -> if short then () else raise Short_list in
459       aux f (Option.is_some short) xs ys
461     let rec fold_left f z = function
462     | [] -> z
463     | x::xs -> fold_left f (f z x) xs
465     let fold_left1 f = function
466     | [] -> raise Short_list
467     | x::xs -> fold_left f x xs
469     let fold_left2 f z ?short xs ys =
470       let rec aux f short z xs ys = match xs, ys with
471       | [],[] -> z
472       | x::xs,y::ys -> aux f short (f z x y) xs ys
473       | _ -> if short then z else raise Short_list in
474     aux f (Option.is_some short) z xs ys
476     let rec fold_right f xs z =
477       let rec aux f z = function
478       | [] -> z
479       | x::xs -> aux f (f x z) xs in
480     aux f z (rev1 [] xs)
482     let fold_right1 f xs =
483       let rec aux f z = function
484       | [] -> z
485       | x::xs -> aux f (f x z) xs in
486     match rev1 [] xs with
487     | [] -> raise Short_list
488     | x::xs -> aux f x xs
490     let fold_right2 f ?short xs ys z =
491       let rec aux f short z xs ys = match xs, ys with
492       | [],[] -> z
493       | x::xs,y::ys -> aux f short (f x y z) xs ys
494       | _ -> if short then z else raise Short_list in
495     aux f (Option.is_some short) z (rev1 [] xs) (rev1 [] ys)
497     let rec for_all p = function [] -> true | x::xs -> p x && for_all p xs
498     let rec exists p = function [] -> false | x::xs -> p x || exists p xs
500     let rec for_all2 p xs ys = match xs,ys with [],[] -> true | x::xs,y::ys -> p x y && for_all2 p xs ys | _ -> raise Short_list
501     let rec exists2 p xs ys = match xs,ys with [],[] -> false | x::xs,y::ys -> p x y || exists2 p xs ys | _ -> raise Short_list
503     let maximum ?rev ?(cmp=compare) xs =
504       let rec aux select cmp sofar = function
505       | [] -> sofar
506       | x::xs -> let res = cmp x sofar in aux select cmp (if res < 0 then sofar else if res = 0 then select sofar x else x) xs in
507       match rev,xs with
508       | None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs
509       | Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs
510       | _ -> raise Short_list
512     let minimum ?rev ?(cmp=compare) xs =
513       let rec aux select cmp sofar = function
514       | [] -> sofar
515       | x::xs -> let res = cmp x sofar in aux select cmp (if res > 0 then sofar else if res = 0 then select sofar x else x) xs in
516       match rev,xs with
517       | None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs
518       | Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs
519       | _ -> raise Short_list
521     (*
522     let maximumx ?rev ?(cmp=compare) xs =
523       let rec aux select cmp i sofar = function
524       | [] -> sofar
525       | x::xs -> let res = cmp x (snd sofar) in aux select cmp (i+1) (if res < 0 then sofar else if res = 0 then select sofar i x else (i,x)) xs in
526       match rev,xs with
527       | None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs
528       | Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs
529       | _ -> raise Short_list
531     let minimumx ?rev ?(cmp=compare) xs =
532       let rec aux select cmp i sofar = function
533       | [] -> sofar
534       | x::xs -> let res = cmp x (snd sofar) in aux select cmp (i+1) (if res > 0 then sofar else if res = 0 then select sofar i x else (i,x)) xs in
535       match rev,xs with
536       | None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs
537       | Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs
538       | _ -> raise Short_list
539     *)
541     let maxby f ?(cmp=compare) ?rev xs =
542       let rec aux f cmp thresh (_,_,fw as prev) i = function
543       | [] -> prev
544       | x::xs -> aux f cmp thresh (let fx = f x in if cmp fx fw > thresh then (i,x,fx) else prev) (i+1) xs in
545       match rev,xs with
546       | _,[] -> raise Short_list
547       | None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs
548       | Some _,x::xs -> aux f cmp (-1) (0,x,f x) 1 xs
550     let minby f ?(cmp=compare) ?rev xs =
551       let rec aux f cmp thresh (_,_,fw as prev) i = function
552       | [] -> prev
553       | x::xs -> aux f cmp thresh (let fx = f x in if cmp fx fw < thresh then (i,x,fx) else prev) (i+1) xs in
554       match rev,xs with
555       | _,[] -> raise Short_list
556       | None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs
557       | Some _,x::xs -> aux f cmp (+1) (0,x,f x) 1 xs
559     let sum xs = fold_left ( + ) 0 xs
560     let product xs = fold_left ( * ) 1 xs
562     let take n xs =
563       let rec aux n ys = function
564         | _ when n = 0 -> rev1 [] ys
565         | [] -> raise Short_list
566         | x::xs -> aux (n-1) (x::ys) xs in
567       if n < 0 then invalid_arg "take" else aux n [] xs
569     let take' n xs =
570       let rec aux n ys = function
571         | _ when n = 0 -> rev1 [] ys
572         | [] -> rev1 [] ys
573         | x::xs -> aux (n-1) (x::ys) xs in
574       if n < 0 then invalid_arg "take'" else aux n [] xs
576     let drop n xs =
577       let rec aux n = function
578         | xs when n = 0 -> xs
579         | [] -> raise Short_list
580         | _::xs -> aux (n-1) xs in
581       if n < 0 then invalid_arg "drop" else aux n xs
583     let drop' n xs =
584       let rec aux n = function
585         | xs when n = 0 -> xs
586         | [] -> []
587         | _::xs -> aux (n-1) xs in
588       if n < 0 then invalid_arg "drop'" else aux n xs
590     let split n xs =
591       let rec aux n ys = function
592         | xs when n = 0 -> rev1 [] ys, xs
593         | [] -> raise Short_list
594         | x::xs -> aux (n-1) (x::ys) xs in
595       if n < 0 then invalid_arg "split" else aux n [] xs
597     let split' n xs =
598       let rec aux n ys = function
599         | xs when n = 0 -> rev1 [] ys, xs
600         | [] -> rev1 [] ys, []
601         | x::xs -> aux (n-1) (x::ys) xs in
602       if n < 0 then invalid_arg "split'" else aux n [] xs
604     let nth xs n =
605       let rec aux n = function
606         | x::xs -> if n = 0 then x else aux (n-1) xs
607         | [] -> raise Short_list in
608       if n < 0 then invalid_arg "nth" else aux n xs
610     let modify n f xs =
611       let rec aux n f i ys = function
612       | [] -> raise Short_list
613       | x::xs -> if n = i then rev1 ((f x)::xs) ys else aux n f (i+1) (x::ys) xs in
614       if n < 0 then invalid_arg "modify" else aux n f 0 [] xs
616     let optmodify n f xs =
617       let rec aux n f i ys = function
618       | [] -> raise Short_list
619       | x::xs -> if n = i then rev1 (match f x with Some x -> x::xs | None -> xs) ys else aux n f (i+1) (x::ys) xs in
620       if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs
622     let catmodify n f xs =
623       let rec aux n f i ys = function
624       | [] -> raise Short_list
625       | x::xs -> if n = i then rev1 xs (rev1 ys (f x)) else aux n f (i+1) (x::ys) xs in
626       if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs
628     let take_while p ?rev xs =
629       let rec aux_left p ys = function
630         | [] -> xs
631         | x::xs -> if p x then aux_left p (x::ys) xs else rev1 [] ys in
632       let rec aux_right p ys = function
633         | [] -> rev1 [] ys
634         | x::xs -> if p x then aux_right p (x::ys) xs else aux_right p [] xs in
635       match rev with
636       | None -> aux_left p [] xs
637       | Some _ -> aux_right p [] xs
639     let drop_while p ?rev xs =
640       let rec aux_left p = function
641         | [] -> []
642         | x::xs as orig -> if p x then aux_left p xs else orig in
643       let rec aux_right p matching yss ys = function
644         | [] -> if matching then rev2 [] yss else xs
645         | x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs
646                    else aux_right p (not matching) (ys::yss) [x] xs in
647       match rev with
648       | None -> aux_left p xs
649       | Some _ -> aux_right p false [] [] xs
651     let split_while p ?rev xs =
652       let rec aux_left p ys = function
653         | [] -> xs, []
654         | x::xs as orig -> if p x then aux_left p (x::ys) xs else rev1 [] ys, orig in
655       let rec aux_right p matching yss ys = function
656         | [] -> if matching then rev2 [] yss, rev1 [] ys else xs, []
657         | x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs
658                    else aux_right p (not matching) (ys::yss) [x] xs in
659       match rev with
660       | None -> aux_left p [] xs
661       | Some _ -> aux_right p false [] [] xs
663     let find p ?rev xs =
664       let rec aux_left p = function [] -> raise Not_found | x::xs -> if p x then x else aux_left p xs in
665       let rec aux_right p prev = function
666       | [] -> (match prev with None -> raise Not_found | Some x -> x)
667       | x::xs -> aux_right p (if p x then Some x else prev) xs in
668       match rev with
669       | None -> aux_left p xs
670       | Some _ -> aux_right p None xs
672     let optfind p ?rev xs =
673       let rec aux_left p = function [] -> raise Not_found | x::xs -> (match p x with Some y -> y | None -> aux_left p xs) in
674       let rec aux_right p prev = function
675       | [] -> (match prev with None -> raise Not_found | Some x -> x)
676       | x::xs -> aux_right p (match p x with Some y -> Some y | None -> prev) xs in
677       match rev with
678       | None -> aux_left p xs
679       | Some _ -> aux_right p None xs
681     let findx p ?rev xs =
682       let rec aux_left p i = function [] -> raise Not_found | x::xs -> if p x then (i,x) else aux_left p (i+1) xs in
683       let rec aux_right p i prev = function
684       | [] -> (match prev with None -> raise Not_found | Some (i,x as res) -> res)
685       | x::xs -> aux_right p (i+1) (if p x then Some (i,x) else prev) xs in
686       match rev with
687       | None -> aux_left p 0 xs
688       | Some _ -> aux_right p 0 None xs
690     let index sought ?rev ?(eq=(=)) ?cmp xs =
691       let rec aux_left eq sought i = function [] -> raise Not_found | x::xs -> if eq x sought then i else aux_left eq sought (i+1) xs in
692       let rec aux_right eq sought i prev = function [] -> if prev < 0 then raise Not_found else prev | x::xs -> aux_right eq sought (i+1) (if eq x sought then i else prev) xs in
693       let rec aux_sorted cmp sought i = function
694       | x::xs -> let res = cmp x sought in if res > 0 then raise Not_found else if res = 0 then i else aux_sorted cmp sought (i+1) xs
695       | [] -> raise Not_found in
696       match cmp,rev with
697       | None,None -> aux_left eq sought 0 xs
698       | None,Some _ -> aux_right eq sought 0 (-1) xs
699       | Some cmp,None -> aux_sorted cmp sought 0 xs
700       | Some _,Some _ -> invalid_arg "index ~rev conflicts with ~cmp"
702     let indexq sought xs =
703       let rec aux sought i = function [] -> raise Not_found | x::xs -> if x == sought then i else aux sought (i+1) xs in
704       aux sought 0 xs
706     let remove p ?rev ?many xs =
707       let rec aux_left p ys = function [] -> xs | x::xs -> if p x then rev1 xs ys else aux_left p (x::ys) xs in
708       let rec aux_many p ys = function [] -> rev1 [] ys | x::xs -> aux_many p (if p x then ys else x::ys) xs in
709       let rec aux_right p yss ys = function
710       | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
711       | x::xs -> if p x then aux_right p ((x::ys)::yss) [] xs else aux_right p yss (x::ys) xs in
712       match rev,many with
713       | None,None -> aux_left p [] xs
714       | Some _,None -> aux_right p [] [] xs
715       | None,Some _ -> aux_many p [] xs
716       | Some _,Some _ -> invalid_arg "remove ~rev conflicts with ~many"
718     let delete sought ?rev ?(eq=(=)) ?cmp ?many xs =
719       let rec aux_left eq sought ys = function [] -> xs | x::xs -> if eq x sought then rev1 xs ys else aux_left eq sought (x::ys) xs in
720       let rec aux_many eq sought ys = function [] -> rev1 [] ys | x::xs -> aux_many eq sought (if eq x sought then ys else x::ys) xs in
721       let rec aux_right eq sought yss ys = function
722       | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
723       | x::xs -> if eq x sought then aux_right eq sought ((x::ys)::yss) [] xs else aux_right eq sought yss (x::ys) xs in
724       let rec aux_sorted cmp sought ys = function
725       | [] -> xs
726       (* don't shadow the entry-level `xs` *)
727       | z::zs -> let res = cmp z sought in if res > 0 then xs else if res = 0 then rev1 zs ys else aux_sorted cmp sought (z::ys) zs in
728       let rec aux_msorted cmp sought ys = function
729       | [] -> rev1 [] ys
730       | x::xs as orig -> let res = cmp x sought in if res > 0 then rev1 orig ys else aux_msorted cmp sought (if res = 0 then ys else x::ys) xs in
731       match cmp,rev,many with
732       | None,None,None -> aux_left eq sought [] xs
733       | None,Some _,None -> aux_right eq sought [] [] xs
734       | Some cmp,None,None -> aux_sorted cmp sought [] xs
735       | None,None,Some _ -> aux_many eq sought [] xs
736       | Some cmp,None,Some _ -> aux_msorted cmp sought [] xs
737       | Some _,Some _,None -> invalid_arg "delete ~rev conflicts with ~cmp"
738       | None,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many"
739       | Some _,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many and ~cmp"
741     let deleteq sought xs =
742       let rec aux sought ys = function [] -> xs | x::xs -> if x == sought then rev1 xs ys else aux sought (x::ys) xs in
743       aux sought [] xs
745     let pick p ?rev xs =
746       let rec aux_left p ys = function [] -> raise Not_found | x::xs -> if p x then x, rev1 xs ys else aux_left p (x::ys) xs in
747       let rec aux_right p prev yss ys = function
748       | [] -> (match prev, yss with None,_ -> raise Not_found | Some x,(_::xs)::yss -> x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
749       | x::xs -> if p x then aux_right p (Some x) ((x::ys)::yss) [] xs else aux_right p prev yss (x::ys) xs in
750       match rev with
751       | None -> aux_left p [] xs
752       | Some _ -> aux_right p None [] [] xs
754     let pickx p ?rev xs =
755       let rec aux_left p i ys = function [] -> raise Not_found | x::xs -> if p x then i, x, rev1 xs ys else aux_left p (i+1) (x::ys) xs in
756       let rec aux_right p i prev yss ys = function
757       | [] -> (match prev, yss with None,_ -> raise Not_found | Some (i,x),(_::xs)::yss -> i, x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
758       | x::xs -> if p x then aux_right p (i+1) (Some (i,x)) ((x::ys)::yss) [] xs else aux_right p (i+1) prev yss (x::ys) xs in
759       match rev with
760       | None -> aux_left p 0 [] xs
761       | Some _ -> aux_right p 0 None [] [] xs
763     let filter p ?rev ?(onto=[]) xs =
764       let rec aux p ys = function [] -> ys | x::xs -> aux p (if p x then x::ys else ys) xs in
765       match rev with
766       | None -> rev1 onto (aux p [] xs)
767       | Some _ -> aux p onto xs
769     (*
770     val filteri : (int -> 'a -> bool) -> ?onto:'a list -> 'a list -> 'a list
771     let filteri p ?(onto=[]) xs =
772       let rec aux p i ys = function [] -> ys | x::xs -> aux p (i+1) (if p i x then x::ys else ys) xs in
773       rev1 onto (aux p 0 [] xs)
774     *)
776     let filterx p xs =
777       let rec aux p i ys = function [] -> ys | x::xs -> aux p (i+1) (if p x then (i,x)::ys else ys) xs in
778       rev1 [] (aux p 0 [] xs)
780     let indices sought ?(eq=(=)) xs =
781       let rec aux eq sought i ys = function [] -> ys | x::xs -> aux eq sought (i+1) (if eq x sought then i::ys else ys) xs in
782       rev1 [] (aux eq sought 0 [] xs)
784     let indicesq sought xs =
785       let rec aux sought i ys = function [] -> ys | x::xs -> aux sought (i+1) (if x == sought then i::ys else ys) xs in
786       rev1 [] (aux sought 0 [] xs)
788     (* remove ~many p, delete ~many x *)
790     let partition p xs =
791       let rec aux p ys ns = function
792       | [] -> if ys = [] then [], xs else if ns = [] then xs, [] else rev1 [] ys, rev1 [] ns
793       | x::xs -> if p x then aux p (x::ys) ns xs else aux p ys (x::ns) xs in
794       aux p [] [] xs
796     let partitionx p xs =
797       let rec aux p i ys ns = function
798       | [] -> rev1 [] ys, rev1 [] ns
799       | x::xs -> if p x then aux p (i+1) ((i,x)::ys) ns xs else aux p (i+1) ys ((i,x)::ns) xs in
800       aux p 0 [] [] xs
802     let assoc sought ?rev ?(eq=(=)) xs =
803       let rec aux_left sought eq = function
804       | [] -> raise Not_found
805       | (k,x)::xs -> if eq k sought then x else aux_left sought eq xs in
806       let rec aux_right sought eq prev = function
807       | [] -> (match prev with None -> raise Not_found | Some x -> x)
808       | (k,x)::xs -> aux_right sought eq (if eq k sought then Some x else prev) xs in
809       match rev with
810       | None -> aux_left sought eq xs
811       | Some _ -> aux_right sought eq None xs
813     let rec assq sought ?rev xs =
814       let rec aux_left sought = function
815       | [] -> raise Not_found
816       | (k,x)::xs -> if k == sought then x else assq sought xs in
817       let rec aux_right sought prev = function
818       | [] -> (match prev with None -> raise Not_found | Some x -> x)
819       | (k,x)::xs -> aux_right sought (if k == sought then Some x else prev) xs in
820       match rev with
821       | None -> aux_left sought xs
822       | Some _ -> aux_right sought None xs
824     let modify_assoc sought f ?missing ?rev ?(eq=(=)) xs =
825       let rec aux_left sought f eq ys = function
826       | [] -> None
827       | (k,x as kx)::xs -> if eq k sought then Some (rev1 ((k,f k x)::xs) ys) else aux_left sought f eq (kx::ys) xs in
828       let rec aux_right sought f eq yss ys = function
829       | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
830       | (k,x as kx)::xs -> if eq k sought then aux_right sought f eq ((kx::ys)::yss) [] xs else aux_right sought f eq yss (kx::ys) xs in
831       match rev,missing with
832       | None,None -> (match aux_left sought f eq [] xs with None -> raise Not_found | Some xs -> xs)
833       | None,Some m -> (match aux_left sought f eq [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
834       | Some _,None -> (match aux_right sought f eq [] [] xs with None -> raise Not_found | Some xs -> xs)
835       | Some _,Some m -> (match aux_right sought f eq [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
837     let optmodify_assoc sought f ?rev ?(eq=(=)) xs =
838       let rec aux_left sought f eq ys = function
839       | [] -> None
840       | (k,x as kx)::xs -> if eq k sought then Some (rev1 (match f k (Some x) with None -> xs | Some x -> (k,x)::xs) ys) else aux_left sought f eq (kx::ys) xs in
841       let rec aux_right sought f eq yss ys = function
842       | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 (match f k (Some x) with None -> rev1 [] ys | Some x -> (k,x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
843       | (k,x as kx)::xs -> if eq k sought then aux_right sought f eq ((kx::ys)::yss) [] xs else aux_right sought f eq yss (kx::ys) xs in
844       match rev with
845       | None -> (match aux_left sought f eq [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
846       | Some _ -> (match aux_right sought f eq [] [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
848     let modify_assq sought f ?missing ?rev xs =
849       let rec aux_left sought f ys = function
850       | [] -> None
851       | (k,x as kx)::xs -> if k == sought then Some (rev1 ((k,f k x)::xs) ys) else aux_left sought f (kx::ys) xs in
852       let rec aux_right sought f yss ys = function
853       | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
854       | (k,x as kx)::xs -> if k == sought then aux_right sought f ((kx::ys)::yss) [] xs else aux_right sought f yss (kx::ys) xs in
855       match rev,missing with
856       | None,None -> (match aux_left sought f [] xs with None -> raise Not_found | Some xs -> xs)
857       | None,Some m -> (match aux_left sought f [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
858       | Some _,None -> (match aux_right sought f [] [] xs with None -> raise Not_found | Some xs -> xs)
859       | Some _,Some m -> (match aux_right sought f [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
861     let optmodify_assq sought f ?rev xs =
862       let rec aux_left sought f ys = function
863       | [] -> None
864       | (k,x as kx)::xs -> if k == sought then Some (rev1 (match f k (Some x) with None -> xs | Some x -> (k,x)::xs) ys) else aux_left sought f (kx::ys) xs in
865       let rec aux_right sought f yss ys = function
866       | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 (match f k (Some x) with None -> rev1 [] ys | Some x -> (k,x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
867       | (k,x as kx)::xs -> if k == sought then aux_right sought f ((kx::ys)::yss) [] xs else aux_right sought f yss (kx::ys) xs in
868       match rev with
869       | None -> (match aux_left sought f [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
870       | Some _ -> (match aux_right sought f [] [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
872     let rec mem_assoc sought ?(eq=(=)) = function
873     | [] -> false
874     | (k,_)::xs -> eq k sought || mem_assoc ~eq sought xs
876     let rec mem_assq sought = function
877     | [] -> false
878     | (k,_)::xs -> k == sought || mem_assq sought xs
880     let remove_assoc sought ?rev ?(eq=(=)) ?many xs =
881       let rec aux_left sought eq ys = function
882       | [] -> xs
883       | (k,_ as kx)::xs -> if eq k sought then rev1 xs ys else aux_left sought eq (kx::ys) xs in
884       let rec aux_many sought eq ys = function
885       | [] -> rev1 [] ys
886       | (k,_ as kx)::xs -> aux_many sought eq (if eq k sought then ys else kx::ys) xs in
887       let rec aux_right sought eq yss ys = function
888       | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
889       | (k,_ as kx)::xs -> if eq k sought then aux_right sought eq ((kx::ys)::yss) [] xs else aux_right sought eq yss (kx::ys) xs in
890       match rev,many with
891       | None,None -> aux_left sought eq [] xs
892       | Some _,None -> aux_right sought eq [] [] xs
893       | None,Some _ -> aux_many sought eq [] xs
894       | Some _,Some _ -> invalid_arg "remove_assoc ~rev conflicts with ~many"
896     let remove_assq sought ?rev ?many xs =
897       let rec aux_left sought ys = function
898       | [] -> xs
899       | (k,_ as kx)::xs -> if k == sought then rev1 xs ys else aux_left sought (kx::ys) xs in
900       let rec aux_many sought ys = function
901       | [] -> rev1 [] ys
902       | (k,_ as kx)::xs -> aux_many sought (if k == sought then ys else kx::ys) xs in
903       let rec aux_right sought yss ys = function
904       | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
905       | (k,_ as kx)::xs -> if k == sought then aux_right sought ((kx::ys)::yss) [] xs else aux_right sought yss (kx::ys) xs in
906       match rev,many with
907       | None,None -> aux_left sought [] xs
908       | Some _,None -> aux_right sought [] [] xs
909       | None,Some _ -> aux_many sought [] xs
910       | Some _,Some _ -> invalid_arg "remove_assq ~rev conflicts with ~many"
912     let rotate n xs =
913       let rec aux ys = function
914       | [x] -> x::rev1 [] ys
915       | x::xs -> aux (x::ys) xs
916       | _ -> assert false in
917       if n = 0 || xs = [] then xs
918       else if n = 1 then aux [] xs
919       else
920         let xn = length xs in
921         let n = (xn - n) mod xn in
922         let pre,post = if n > 0 then split n xs else if n < 0 then split (xn+n) xs else [],xs in
923         append post pre
925     let unfold f ?rev ?(onto=[]) z =
926       let rec aux f ys z = match f z with None -> ys | Some (y,z) -> aux f (y::ys) z in
927       match rev with
928       | None -> rev1 onto (aux f [] z)
929       | Some _ -> aux f onto z
931     let mapz f z ?rev ?(onto=[]) xs =
932       let rec aux f z ys = function [] -> z,ys | x::xs -> let z,y = f z x in aux f z (y::ys) xs in
933       match rev with
934       | None -> let z,ys = aux f z [] xs in z, rev1 onto ys
935       | Some _ -> aux f z onto xs
937     (*
938     let group ?(eq=(=)) xs =
939       let rec aux eq = function
940       | [] -> []
941       | x::xs -> let xs,ys = split_while (eq x) xs in (x::xs)::aux eq ys in
942       aux eq xs
943     *)
945     let group ?(eq=(=)) xs =
946       let f eq x = function [] -> [[x]] | (y::_ as ys)::yss -> if eq y x then (x::ys)::yss else [x]::ys::yss | _ -> assert false in
947       let rec aux f eq yss = function [] -> yss | x::xs -> aux f eq (f eq x yss) xs in
948       match aux f eq [] xs with [] -> [] | xs -> map ~rev rev xs
950     let cross f xs ys =
951       let rec aux f ys = function [] -> ys | x::xs -> aux f (f x::ys) xs in
952       rev2 [] (aux (fun x -> aux (f x) [] ys) [] xs)
954     let insert ins ?(cmp=compare) ?many xs =
955       let rec aux_one cmp ins ys = function
956       | [] -> rev1 [ins] ys
957       (* don't shadow the entry-level `xs` *)
958       | z::zs as orig -> let res = cmp z ins in if res < 0 then aux_one cmp ins (z::ys) zs else if res = 0 then xs else rev1 (ins::orig) ys in
959       let rec aux_many cmp ins ys = function
960       | [] -> rev1 [ins] ys
961       | x::xs as orig -> let res = cmp x ins in if res < 0 then aux_many cmp ins (x::ys) xs else rev1 (ins::orig) ys in
962       match many with
963       | None -> aux_one cmp ins [] xs
964       | Some _ -> aux_many cmp ins [] xs
966     let select xs is =
967       let rec aux j js i ys = function
968       | [] -> raise Short_list
969       (* don't shadow the entry-level `xs` *)
970       | z::zs as orig -> if j = i then (match js with j::js -> if j >= i then aux j js (if j = i then i else i+1) (z::ys) (if j = i then orig else zs) else aux j js 0 (z::ys) xs | [] -> rev1 [z] ys) else aux j js (i+1) ys zs in
971       match is with
972       | [] -> []
973       | i::is -> aux i is 0 [] xs
975     let range ?(step=1) start ~len =
976       let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in
977       if step = 0 then invalid_arg "range" else aux (if step > 0 then (fun i -> i < start) else (fun i -> i > start)) (-step) [] (start + len*step - step)
979     let range_until ?step start stop =
980       let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in
981       match step with
982       | None -> if stop <= start
983           then aux (fun i -> i > start) (1) [] (let len = (start - stop) in start - len + 1)
984           else aux (fun i -> i < start) (-1) [] (let len = (stop - start) in start + len - 1)
985       | Some x when x < 0 -> if stop >= start then [] else aux (fun i -> i > start) (-x) [] (let len = (stop + x + 1 - start) / x in start + len*x - x)
986       | Some x when x > 0 -> if stop <= start then [] else aux (fun i -> i < start) (-x) [] (let len = (stop + x - 1 - start) / x in start + len*x - x)
987       | _ -> invalid_arg "range_until"
989     let unique ?cmp ?(eq=(=)) xs =
990       let rec aux_mem eq x = function [] -> false | y::ys -> eq y x || aux_mem eq x ys in
991       let rec aux_all eq ys = function
992       | [] -> rev1 [] ys
993       | x::xs -> aux_all eq (if aux_mem eq x ys then ys else x::ys) xs in
994       let rec aux_sorted cmp ys y = function
995       | [] -> rev1 [y] ys
996       | x::xs -> if cmp y x = 0 then aux_sorted cmp ys y xs else aux_sorted cmp (y::ys) x xs in
997       match xs,cmp with
998       | [],_ | [_],_ -> xs
999       | x::xs, None -> aux_all eq [x] xs
1000       | x::xs, Some cmp -> aux_sorted cmp [] x xs
1002     let is_unique ?cmp ?(eq=(=)) xs =
1003       let rec aux_mem eq sought = function [] -> false | x::xs -> eq x sought || aux_mem eq sought xs in
1004       let rec aux_all eq ys = function
1005       | [] -> true
1006       | x::xs -> not (aux_mem eq x ys) && aux_all eq (x::ys) xs in
1007       let rec aux_sorted cmp y = function
1008       | [] -> true
1009       | x::xs -> cmp y x < 0 && aux_sorted cmp x xs in
1010       match xs,cmp with
1011       | [],_ | [_],_ -> true
1012       | x::xs, None -> aux_all eq [x] xs
1013       | x::xs, Some cmp -> aux_sorted cmp x xs
1015     let rec transpose = function
1016       | [] -> []
1017       | []::xss -> transpose xss
1018       | (x::xs)::xss -> (x :: map head xss) :: transpose (xs :: map tail xss)
1020     let sublists ?len ?many xs =
1021       let rec aux_all = function [] -> [] | (x::xs) -> [x]::fold_left (fun yss ys -> (x::ys)::ys::yss) [] (aux_all xs) in
1022       let rec aux_fixed k = function
1023       | _  when k = 0 -> [[]]
1024       | [] -> [] (* happens if k > length xs *)
1025       | x::xs -> map (cons x) (aux_fixed (k-1) xs) ~onto:(aux_fixed k xs) in
1026       let rec aux_replacing k = function
1027         | _ when k = 0 -> [[]]
1028         | [] -> [] (* will only happen if xs was [] to start with *)
1029         | x::xs as orig -> map (cons x) (aux_replacing (k-1) orig) ~onto:(aux_replacing k xs) in
1030       match len,many with
1031       | None,None -> []::aux_all xs
1032       | Some k,None -> if k < 0 then invalid_arg "sublists ~len" else aux_fixed k xs
1033       | Some k,Some _ -> if k < 0 then invalid_arg "sublists ~len" else aux_replacing k xs
1034       | None,Some _ -> invalid_arg "sublists ~many requires ~len"
1036     let rec permutations ?len ?many xs =
1037       let rec interleave' x xs f r = function
1038       | [] -> xs, r
1039       | y::ys -> let us,zs = interleave' x xs (fun ys -> f(y::ys)) r ys in y::us, f (x::y::us)::zs in
1040       let interleave x xs r ys = let _,zs = interleave' x xs ident r ys in zs in
1041       let rec aux ys = function
1042       | [] -> []
1043       | x::xs -> fold_left (interleave x xs) (aux (x::ys) xs) (permutations ys) in
1044       let prod yss xs = catmap (fun x -> map (cons x) yss) xs in
1045       match len,many with
1046       | None,None -> xs::aux [] xs
1047       | Some k,None -> if k < 0 then invalid_arg "permutations ~len" else catmap permutations (sublists ~len:k xs)
1048       | Some k,Some _ -> if k < 0 then invalid_arg "permuations ~len" else if k = 0 then [] else fold_left prod [[]] (make k xs)
1049       | None, Some _ -> invalid_arg "permutations ~many requires ~len"
1051     let is_sublist ?(eq=(=)) xs ys =
1052       let rec aux eq ys xs = match ys,xs with
1053       | _,[] -> true
1054       | [],_::_ -> false
1055       | y::ys',x::xs' -> if eq y x then aux eq ys' xs' else aux eq ys' xs in
1056       aux eq ys xs
1058     let is_subset ?cmp ?(eq=(=)) ?many xs ys =
1059       let rec aux_sorted uniq cmp ys xs = match ys,xs with
1060       | _,[] -> true
1061       | [],_::_ -> false
1062       | y::ys',x::xs' -> let res = cmp y x in if res > 0 then false else if res < 0 then aux_sorted uniq cmp ys' xs else aux_sorted uniq cmp (if uniq then ys' else ys) xs' in
1063       match cmp,many with
1064       | None,Some _ -> for_all (fun x -> mem ~eq x ys) xs
1065       | Some cmp,None -> aux_sorted true cmp ys xs
1066       | Some cmp,Some _ -> aux_sorted false cmp ys xs
1067       | None,None -> invalid_arg "is_subset requires ~cmp and/or ~many"
1069     let is_eqset ?(eq=(=)) xs ys =
1070       let rec aux eq x zs = function [] -> raise Not_found | y::ys -> if eq y x then x, rev1 ys zs else aux eq x (y::zs) ys in
1071       try (match fold_left (fun ys x -> let _,ys = aux eq x [] ys in ys) ys xs with [] -> true | _ -> false)
1072       with Not_found -> false
1074     let rec lexcmp ?(cmp=compare) xs ys = match xs, ys with
1075     | [],[] -> 0
1076     | _,[] -> 1
1077     | [],_ -> -1
1078     | x::xs,y::ys -> let res = cmp x y in if res < 0 then -1 else if res > 0 then 1 else lexcmp ~cmp xs ys
1080     let diff ?cmp ?(eq=(=)) ?many xs ys = fold_left (fun xs y -> delete ?cmp ~eq ?many y xs) xs ys
1082     (*
1083     let union ?cmp ?(eq=(=)) xs ys = append xs (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs)
1084     *)
1086     let union ?cmp ?(eq=(=)) ys xs = append (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs) xs
1088     let intersect ?cmp ?(eq=(=)) xs ys =
1089       let rec aux_all eq ws zs xs ys = match xs,ys with
1090       | _,[] -> rev1 [] zs
1091       | [],y::ys' -> aux_all eq [] zs (* don't need to reverse ws *) ws ys'
1092       | x::xs',y::ys' -> if eq x y then aux_all eq [] (y::zs) (rev1 xs' ws) ys' else aux_all eq (x::ws) zs xs' ys in
1093       let rec aux_sorted cmp zs xs ys = match xs,ys with
1094       | [],_ | _,[] -> rev1 [] zs
1095       | x::xs',y::ys' -> let res = cmp x y in if res < 0 then aux_sorted cmp zs xs' ys else if res > 0 then aux_sorted cmp zs xs ys' else aux_sorted cmp (y::zs) xs' ys' in
1096       match cmp with
1097       | None -> aux_all eq [] [] xs ys
1098       | Some cmp -> aux_sorted cmp [] xs ys
1100     let merge ?(cmp=compare) xs ys =
1101       let rec aux cmp zs xs ys = match xs, ys with
1102       | [],ys -> rev1 ys zs
1103       | xs,[] -> rev1 xs zs
1104       | x'::xs',y'::ys' -> if cmp x' y' <= 0 then aux cmp (x'::zs) xs' ys else aux cmp (y'::zs) xs ys' in
1105       aux cmp [] xs ys
1107     (*
1108        "Natural" or "adaptive" bottom-up merge sort, inspired by http://www.drmaciver.com/tag/timsort/.
1110        Optimized to exploit existing runs of ascending/descending elements, to consume at most O(log n) levels of its working stack,
1111        and to be mostly tail-recursive, while minimizing how often sorted and merged runs need to be reversed.
1113        Sort is stable, and has O(n log n) avg and worst-case behavior.
1114        (Compare to naive mergesort on random data, also to C-implemented qsort, which isn't stable?)
1116        Will delete (later occurrences of) any duplicates, unless invoked with ~many.
1118        Copyright (c) 2012, 2015 by Dubiousjim <dubiousjim@gmail.com>.
1120     *)
1122     let sort ?(cmp=compare) ?many ?rev xs =
1123       let rec merge uniq cmp wasc yy zz ws wn =
1124         assert (wasc <> 0); match yy,zz with
1125         | us,[] | [],us -> rev1 ws us, wn, -wasc
1126         | y::ys,z::zs -> let res = cmp y z in
1127             if uniq && res = 0 then (assert (wn<>1); merge uniq cmp wasc ys zz ws (if wn = 0 then 0 else wn - 1))
1128             else if (wasc < 0) = (res < 0) then merge uniq cmp wasc ys zz (y::ws) wn else merge uniq cmp wasc yy zs (z::ws) wn in
1129       let rec merge1 uniq cmp ys yn yasc zss = match zss with
1130         | [] -> None
1131         | (z::zs' as zs,zn,zasc)::zss as orig -> (match ys with
1132             | [] -> assert false
1133             | y::ys' ->
1134                 (* yn = 0 forces collapse of stack *)
1135                 if yn > 0 && yn*2 <= zn then None
1136                 else let wn = if yn > 0 then yn + zn else 0 in
1137                 if yasc = 0 then (assert (yn <= 1); merge2 uniq cmp zss (merge uniq cmp zasc ys zs [] wn))
1138                 else let res = cmp y z in
1139                 let () = assert (yn <> 1) in
1140                 if uniq && res = 0 then (if yn = 1 then merge2 uniq cmp zss (zs,zn,zasc) else merge1 uniq cmp ys' (if yn = 0 then 0 else yn - 1) yasc orig)
1141                 else if yasc < 0 && zasc > 0 && res >= 0 then merge2 uniq cmp zss (rev1 zs ys, wn, 1)
1142                 else if yasc > 0 && zasc < 0 && res < 0 then merge2 uniq cmp zss (rev1 ys zs, wn, 1)
1143                 else let wasc,ys,zs = if (yasc < 0) = (zasc < 0) then zasc, ys, zs else if zn < yn then yasc, ys, rev1 [] zs else zasc, rev1 [] ys, zs in
1144                 merge2 uniq cmp zss (merge uniq cmp wasc ys zs [] wn))
1145         | _ -> assert false
1146       and merge2 uniq cmp zss (ws,wn,wasc) =
1147         let more = merge1 uniq cmp ws wn wasc zss in
1148         match more with None -> Some ((ws,wn,wasc)::zss) | _ -> more in
1149       (* yasc = -1 when a segment of the original list was strictly descending, +1 when it was non-descending, 0 when the segment is only 1 member long *)
1150       let rec step uniq cmp xs y ys yn yasc zss =
1151         match xs with
1152         | (x::xs) ->
1153             let res = cmp x y in
1154             if uniq && res = 0 then step uniq cmp xs y ys yn yasc zss
1155             else if yn = 1 then step uniq cmp xs x (y::ys) 2 (if res < 0 then -1 else 1) zss
1156             else (assert (yasc <> 0); if (yasc < 0) = (res < 0) then step uniq cmp xs x (y::ys) (yn+1) yasc zss
1157             else step uniq cmp xs x [] 1 0 (match merge1 uniq cmp (y::ys) yn yasc zss with None -> (y::ys,yn,yasc)::zss | Some zss -> zss))
1158         | [] -> (* finished stepping through original list, use yn = 0 to force merge1 until completion *)
1159             (match merge1 uniq cmp (y::ys) 0 yasc zss with
1160             | Some [(ys,0,yasc)] -> if yasc > 0 then rev1 [] ys else ys
1161             | None -> if yasc > 0 then rev1 [y] ys else y::ys
1162             | _ -> assert false) in
1163     match many,rev,xs with
1164     | _,_,[] | _,_,[_] -> xs
1165     | None,None,x::xs -> step true cmp xs x [] 1 0 []
1166     | Some _,None,x::xs -> step false cmp xs x [] 1 0 []
1167     | None,Some _,x::xs -> step true (fun x y -> -cmp x y) xs x [] 1 0 []
1168     | Some _,Some _,x::xs -> step false (fun x y -> -cmp x y) xs x [] 1 0 []
1170     let is_sorted ?(cmp=compare) ?many ?rev xs =
1171       let rec aux cmp thresh y = function
1172       | [] -> true
1173       | x::xs -> cmp y x < thresh && aux cmp thresh x xs in
1174       match rev,xs with
1175       | _,[] | _,[_] -> true
1176       | None,x::xs -> aux cmp (match many with None -> 0 | Some _ -> 1) x xs
1177       | Some _,x::xs -> aux (fun x y -> -cmp x y) (match many with None -> 0 | Some _ -> 1) x xs
1180     let string_of_list ?(brackets=true) ?(sep=";") f xs =
1181       let rec aux sep' = function [] -> if brackets then "]" else "" | x::xs -> sep' ^ f x ^ aux sep xs in
1182       (if brackets then "[" else "") ^ aux "" xs
1184     let histogram ?(eq=(=)) xs = fold_left (fun h x -> modify_assoc x (fun _ n -> n+1) ~missing:(fun _ -> 1) ~eq h) [] xs
1186     let pairwise ?missing xs =
1187       let rec aux missing x = function
1188       | [] -> (match missing with None -> [] | Some y -> [(x,y)])
1189       | y::ys -> (x,y)::aux missing y ys in
1190       match xs with
1191       | [] -> []
1192       | x::xs -> aux missing x xs
1194     let rec round_robin xss =
1195       let rec aux ws ys = function
1196       | [] -> (match ys with [] -> rev1 [] ws | _ -> aux ws [] (rev1 [] ys))
1197       | []::xss -> aux ws ys xss
1198       | (x::xs)::xss -> aux (x::ws) (xs::ys) xss in
1199       match xss with
1200       | [] -> raise Short_list
1201       | []::xss -> round_robin xss
1202       | xss -> aux [] [] xss
1204     let rec chunk n xs = match split n xs with
1205       | ys,[] -> [ys]
1206       | ys,zs -> ys::chunk n zs
1208     let rec chunk' n xs = match split' n xs with
1209       | ys,[] -> [ys]
1210       | ys,zs -> ys::chunk' n zs
1212     let chunk_int n xs =
1213       let rec aux n = function
1214       | _ when n = 0 -> [[]]
1215       | [] -> []
1216       | x::xs as orig -> if x > n then aux n xs else map ~onto:(aux n xs) (cons x) (aux (n-x) orig) in
1217       let xs = sort ~many xs in
1218       match sort xs with x::_ as xs when x > 0 && n > 0 -> aux n (rev1 [] xs) | _ -> invalid_arg "chunk_int"
1220     let chunk_range sizes =
1221       let rec combs2 k = function
1222       | xs when k = 0 -> [([],xs)]
1223       | [] -> []
1224       | x::xs -> map (fun (cs,zs) -> x::cs,zs) (combs2 (k-1) xs) ~onto:(map (fun (cs,zs) -> cs,x::zs) (combs2 k xs)) in
1225       let rec p xs = function
1226       | [] -> [[]]
1227       | k::ks -> catmap (fun (cs,zs) -> map (cons cs) (p zs ks)) (combs2 k xs) in
1228       if exists (fun x -> x<0) sizes then invalid_arg "chunk_range" else p (range_until 0 (sum sizes)) sizes
1230   end (* List *)
1232   let short = List.short
1233   let many = List.many
1234   exception Short_list = List.Short_list
1236   let is_null = List.is_null
1237   let length = List.length
1238   let cons = List.cons
1239   let snoc = List.snoc
1240   let singleton = List.singleton
1243   let tail = List.tail
1244   let tail' = List.tail'
1245   let uncons = List.uncons
1246   let append = List.append
1247   let concat = List.concat
1248   let rev = List.rev
1249   let zip = List.zip
1250   let unzip = List.unzip
1251   let iter = List.iter
1252   let iteri = List.iteri
1253   let iter2 = List.iter2
1254   let fold_left = List.fold_left
1255   let fold_left1 = List.fold_left1
1256   let fold_left2 = List.fold_left2
1257   let fold_right = List.fold_right
1258   let fold_right1 = List.fold_right1
1259   let fold_right2 = List.fold_right2
1260   let for_all = List.for_all
1261   let exists = List.exists
1262   let for_all2 = List.for_all2
1263   let exists2 = List.exists2
1264   let sum = List.sum
1265   let product = List.product
1266   let take = List.take
1267   let take' = List.take'
1268   let drop = List.drop
1269   let drop' = List.drop'
1270   let split = List.split
1271   let split' = List.split'
1272   let nth = List.nth
1274 (*
1275   count
1276   make
1277   last
1278   init
1279   init'
1280     mem
1281   map
1282   map2
1283   unmap2
1284   mapi
1285   optmap
1286   optmapi
1287   catmap
1288   catmapi
1289   maximum
1290   minimum
1291   maxby
1292   minby
1293   modify
1294   optmodify
1295   catmodify
1296   take_while
1297   drop_while
1298   split_while
1299   find
1300   optfind
1301   findx
1302     index
1303   remove
1304     delete
1305   pick
1306   pickx
1307   filter
1308   filterx
1309   indices
1310   partition
1311   partitionx
1312     assoc
1313   mem_assoc
1314   modify_assoc
1315   optmodify_assoc
1316   remove_assoc
1317   memq
1318   indexq
1319   deleteq
1320   indicesq
1321   assq
1322   mem_assq
1323   modify_assq
1324   optmodify_assq
1325   remove_assq
1326   rotate
1327   unfold
1328   mapz
1329   group
1330     cross
1331     insert
1332     select
1333     range
1334     range_until
1335     unique
1336     is_unique
1337   transpose
1338   permutations
1339   sublists
1340     is_sublist
1341     is_subset
1342     is_eqset
1343   lexcmp
1344     diff
1345     union
1346     intersect
1347     merge
1348   sort
1349   is_sorted
1350     string_of_list
1351     histogram
1352   pairwise
1353   round_robin
1354   chunk
1355   chunk'
1356   chunk_int
1357   chunk_range
1358 *)
1360   let factorial n = let rec aux m = function 0 -> m | 1 -> m | n -> aux (n*m) (n-1) in aux 1 n
1362   (* good to around n = 28; naive version overflows after n = 20 *)
1363   let choose n k = let j = max k (n-k) in if j = n then 1 else List.fold_left (/) (List.product (List.range_until n j)) (List.range_until (n-j) 1)
1365   module Random : sig
1366     val init : ?seed:int -> unit -> unit
1367     val bool : unit -> bool
1368     (* start <= result < stop *)
1369     val between : int -> int -> int
1370     val nth : 'a list -> 'a
1371     val pick : 'a list -> 'a * 'a list
1372     (* k dice rolls are `permutation ~len:k ~many [1..6]` *)
1373     val permutation : ?len:int -> ?many:'b -> 'a list -> 'a list
1374     (* choose k elements from xs, in stable order, ~many with replacment *)
1375     val sublist : len:int -> ?many:'b -> 'a list -> 'a list
1376   end = struct
1378     let init ?seed () =
1379       match seed with
1380       | None -> Std.Random.self_init()
1381       | Some n -> Std.Random.init n
1383     let bool = Std.Random.bool
1385     let between start stop = Std.Random.int (stop-start) + start
1387     let nth xs = match List.length xs with
1388     | 0 -> invalid_arg "Random.nth"
1389     | n -> List.nth xs (between 0 n)
1391     let pick xs =
1392       let rec aux n ws = function
1393       | x::xs -> if n = 0 then x, List.rev ~onto:xs ws else aux (n-1) (x::ws) xs
1394       | [] -> assert false in
1395       match List.length xs with
1396       | 0 -> invalid_arg "Random.pick"
1397       | n -> aux (between 0 n) [] xs
1399     let permutation ?len ?many xs =
1400       (* a[j],a[n] = x,a[j] *)
1401       let array_push a j n x = if j = n then a.(n) <- x else let y = a.(j) in (a.(j) <- x; a.(n) <- y) in
1402       (* return,a[j] = a[j],a[n] *)
1403       let array_pop a j n = let y = a.(n-1) in if j = n - 1 then y else (let x = a.(j) in a.(j) <- y; x) in
1404       let rec aux_all a n = function
1405       (* Based on https://en.wikipedia.org/wiki/Fisher-Yates_shuffle#The_.22inside-out.22_algorithm
1406          Initialize empty array to shuffled copy of xs *)
1407       | [] -> Array.to_list a
1408       | x::xs -> let j = between 0 (n+1) in (array_push a j n x; aux_all a (n+1) xs) in
1409       let rec aux_fixed k n a ws = function
1410       | 0 -> ws
1411       | i -> let j = between 0 n in let w = array_pop a j n in aux_fixed k (n-1) a (w::ws) (i-1) in
1412     match len,many,xs with
1413     | None,_,[] -> []
1414     | Some k,_,[] -> if k = 0 then [] else invalid_arg "Random.permutation"
1415     | None,None,x::_ -> aux_all (Array.make (List.length xs) x) 0 xs
1416     | Some k,None,_ -> if k < 0 then invalid_arg "Random.permutation" else aux_fixed k (List.length xs) (Array.of_list xs) [] k
1417     | Some k,Some _,_ -> if k < 0 then invalid_arg "Random.permutation" else iterate k (fun ys -> nth xs::ys) []
1418     | None,Some _,_ -> invalid_arg "Random.permutation ~many requires ~len"
1420     let sublist ~len:k ?many xs =
1421       let rec aux_fixed ws n k = function
1422       | _ when k = 0 -> List.rev ws
1423       | (x::xs) ->
1424       (* Explanation of the threshhold: There are n choose k many combinations, yes=(n-1) choose (k-1) headed by element x and no=(n-1) choose k not.
1425          So x has yes/(yes+no) chance of occupying initial slot, else it occupies none of the slots. yes/(yes+no) reduces to k/n. *)
1426          if between 0 n < k then aux_fixed (x::ws) (n-1) (k-1) xs else aux_fixed ws (n-1) k xs
1427       | _ -> assert false in
1428       let rec aux_replacing k top ws = function
1429       | _ when k = 0 -> List.rev ws
1430       | [] -> [] (* will only happen when xs was [] to start with *)
1431       | x::xs as orig ->
1432       (* Explanation of the threshhold: There are n+k-1 choose k many combinations with replacement, yes=(n+k-2) choose (k-1) headed by element x and no=(n+k-2) choose k not.
1433          So x has yes/(yes+no) chance of occupying the initial slot, and also possibly some later slots. This reduces to k/(k+n-1). *)
1434          if between 0 (k+top) < k then aux_replacing (k-1) top (x::ws) orig else aux_replacing k (top-1) ws xs in
1435       let n = List.length xs in
1436       if k < 0 || k > n then invalid_arg "Random.sublist"
1437       else match many with
1438       | None -> aux_fixed [] n k xs
1439       | Some _ -> aux_replacing k (n-1) [] xs
1441   end (* Random *)
1444   module String : sig
1445     type t = string
1446     val compare : 'a -> 'a -> int
1447     val length : string -> int
1448     val take : int -> ?rev:'a -> string -> string
1449     val drop : int -> string -> string
1450     val sub : string -> int -> len:int -> string
1451     val is_prefix : string -> string -> bool
1452     val is_suffix : string -> string -> bool
1453     val is_infix : string -> string -> bool
1454     val find : string -> ?rev:'a -> ?from:int -> string -> int
1455     val nth : string -> int -> char
1456     val make : int -> char -> string
1457     val mem : char -> ?rev:'a -> ?from:int -> string -> bool
1458     val index : ?rev:'a -> ?from:int -> char -> string -> int
1459     val upper : string -> string
1460     val lower : string -> string
1461     val int_of_char : char -> int
1462     val char_of_int : int -> char
1463     (* trim only removes up to 1 leading/trailing occurrence of pat *)
1464     val trim : string -> string
1465     type pat = string
1466     val split : string -> ?n:int -> ?trim:'a -> pat -> string list
1467     val join : sep:string -> string list -> string
1468     val lines : ?trim:'a -> string -> string list (* as in Haskell, gobbles up to 1 \n per line *)
1469     val words : string -> string list
1470     val unlines : string list -> string (* as in Haskell, does add a trailing \n *)
1471     val unwords : string list -> string (* as in Haskell, no trailing space *)
1472   end = struct
1473     type t = string
1474     let compare = compare
1475     let length = Std.String.length
1476     let take n ?rev s = match rev with
1477     | None -> Str.string_before s n
1478     | Some _ -> Str.last_chars s n
1479     let drop n s = Str.string_after s n
1480     let sub s start ~len = Std.String.sub s start len
1481     let is_prefix (sought : string) s = let n = length sought in length s >= n && take n s = sought
1482     let is_suffix (sought : string) s = let n = length sought in length s >= n && take n ~rev:() s = sought
1483     let is_infix (sought : string) s = length sought <= length s && try Str.(search_forward (regexp_string sought) s 0) >= 0 with Not_found -> false
1484     let find (sought : string) ?rev ?from s = match rev,from with
1485     | None,None -> Str.(search_forward (regexp_string sought) s 0)
1486     | None,Some n -> Str.(search_forward (regexp_string sought) s n)
1487     | Some _,Some n -> Str.(search_backward (regexp_string sought) s n)
1488     | Some _,None -> let n = length s - length sought in if n < 0 then raise Not_found else Str.(search_backward (regexp_string sought) s n)
1489     let nth s n = Std.String.get s n
1490     let make n c = Std.String.make n c
1491     let mem (sought : char) ?rev ?from s = match rev,from with
1492     | None,None -> Std.String.contains s sought
1493     | None,Some n -> Std.String.contains_from s n sought
1494     | Some _,Some n -> Std.String.rcontains_from s n sought
1495     | Some _,None -> invalid_arg "String.mem ~rev requires ~from"
1496     let index ?rev ?from (sought : char) s = match rev,from with
1497     | None,None -> Std.String.index s sought
1498     | Some _,None -> Std.String.rindex s sought
1499     | None,Some n -> Std.String.index_from s n sought
1500     | Some _,Some n -> Std.String.rindex_from s n sought
1501     let upper s = Std.String.uppercase s
1502     let lower s = Std.String.lowercase s
1503     let int_of_char (c : char) = Std.Char.code c
1504     let char_of_int (n : int) = Std.Char.chr n
1505     let trim s = Std.String.trim s
1506     type pat = string
1507     let split s ?n ?trim pat = match n,trim with
1508     | None,Some _ -> Str.(split (regexp pat) s)
1509     | Some n,Some _ -> Str.(bounded_split (regexp pat) s n)
1510     | None,None -> Str.(split_delim (regexp pat) s)
1511     | Some n,None -> Str.(bounded_split_delim (regexp pat) s n)
1512     let join ~sep ss = Std.String.concat sep ss
1513     let lines ?trim s = split ("\n"^s) ~trim "\n"
1514     let words s = split s ~trim "[ \t\n]+"
1515     let unlines ss = join "\n" ss ^ "\n"
1516     let unwords ss = join " " ss
1517   end (* String *)
1519 end (* Juli8 *)
1521 open Juli8