1 (* This version from 1 April 2015 *)
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)
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
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 =
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"
53 let undefined () = failwith "undefined"
55 let finally handler f x =
56 let res = (try f x with e -> handler(); raise e) in
59 (* Haskell's `last $ take n $ iterate s z`, might also call `ntimes` *)
60 let rec iterate (n : int) s 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
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` *)
80 (* List.opthead is Haskell's `listToMaybe` *)
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
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
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
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
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'.)
142 (* TODO: cycle n xs *)
143 (* IFFY names: unmap2, mapz, min/maxby, chunk[']/chunk_int/chunk_range, is_eqset, indexq/indicesq/deleteq *)
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
263 (* Based on http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/Data-List.html#permutations
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 = [1] 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];[2];[3;4;5]]; ...]
303 Based on http://rosettacode.org/wiki/Ordered_Partitions#Haskell *)
304 val chunk_range : int list -> int list list list
312 let is_null = function [] -> true | _ -> false
315 let rec aux i = function [] -> i | _::xs -> aux (i+1) xs in
319 let rec aux p n = function [] -> n | x::xs when p x -> aux p (n+1) xs | _::xs -> aux p n xs in
322 let cons x xs = x :: xs
324 let singleton x = [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
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
372 | x::xs -> aux f (f x::onto) xs in
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
381 | _ -> if short then onto else raise Short_list in
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
390 | _ -> if short then onto else raise Short_list in
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
398 | z::zs -> let x,y = f z in aux f (x::xs) (y::ys) zs in
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
406 | (x,y)::zs -> aux (x::xs) (y::ys) zs in
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
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
420 | x::xs -> aux f (match f x with None -> onto | Some x' -> x'::onto) xs in
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
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
434 | x::xs -> aux f (rev1 [] (f x)::onto) xs in
435 let rec aux_rev f onto = function
437 | x::xs -> aux_rev f (rev1 onto (f x)) xs in
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
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
451 let rec aux f i = function [] -> () | x::xs -> f i x; aux f (i+1) xs in
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
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
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
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
479 | x::xs -> aux f (f x z) xs in
482 let fold_right1 f xs =
483 let rec aux f z = function
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
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
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
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
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
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
522 let maximumx ?rev ?(cmp=compare) xs =
523 let rec aux select cmp i sofar = function
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
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
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
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
541 let maxby f ?(cmp=compare) ?rev xs =
542 let rec aux f cmp thresh (_,_,fw as prev) i = function
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
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
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
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
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
570 let rec aux n ys = function
571 | _ when n = 0 -> rev1 [] ys
573 | x::xs -> aux (n-1) (x::ys) xs in
574 if n < 0 then invalid_arg "take'" else aux 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
584 let rec aux n = function
585 | xs when n = 0 -> xs
587 | _::xs -> aux (n-1) xs in
588 if n < 0 then invalid_arg "drop'" else aux 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
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
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
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
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
634 | x::xs -> if p x then aux_right p (x::ys) xs else aux_right p [] xs in
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
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
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
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
660 | None -> aux_left p [] xs
661 | Some _ -> aux_right p false [] [] 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
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
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
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
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
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
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
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
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
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
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
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
766 | None -> rev1 onto (aux p [] xs)
767 | Some _ -> aux p onto xs
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)
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 *)
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
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
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
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
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
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
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
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
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
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
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
874 | (k,_)::xs -> eq k sought || mem_assoc ~eq sought xs
876 let rec mem_assq sought = function
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
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
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
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
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
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
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"
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
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
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
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
934 | None -> let z,ys = aux f z [] xs in z, rev1 onto ys
935 | Some _ -> aux f z onto xs
938 let group ?(eq=(=)) xs =
939 let rec aux eq = function
941 | x::xs -> let xs,ys = split_while (eq x) xs in (x::xs)::aux eq ys in
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
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
963 | None -> aux_one cmp ins [] xs
964 | Some _ -> aux_many cmp ins [] xs
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
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
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
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
996 | x::xs -> if cmp y x = 0 then aux_sorted cmp ys y xs else aux_sorted cmp (y::ys) x xs in
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
1006 | x::xs -> not (aux_mem eq x ys) && aux_all eq (x::ys) xs in
1007 let rec aux_sorted cmp y = function
1009 | x::xs -> cmp y x < 0 && aux_sorted cmp x xs in
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
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
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
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
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
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
1055 | y::ys',x::xs' -> if eq y x then aux eq ys' xs' else aux eq ys' xs in
1058 let is_subset ?cmp ?(eq=(=)) ?many xs ys =
1059 let rec aux_sorted uniq cmp ys xs = match ys,xs with
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
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
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
1083 let union ?cmp ?(eq=(=)) xs ys = append xs (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs)
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
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
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>.
1119 See license at https://github.com/dubiousjim/unspoiled/blob/master/LICENSE
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
1131 | (z::zs' as zs,zn,zasc)::zss as orig -> (match ys with
1132 | [] -> assert false
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))
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 =
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
1173 | x::xs -> cmp y x < thresh && aux cmp thresh x xs in
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
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
1200 | [] -> raise Short_list
1201 | []::xss -> round_robin xss
1202 | xss -> aux [] [] xss
1204 let rec chunk n xs = match split n xs with
1206 | ys,zs -> ys::chunk n zs
1208 let rec chunk' n xs = match split' n xs with
1210 | ys,zs -> ys::chunk' n zs
1212 let chunk_int n xs =
1213 let rec aux n = function
1214 | _ when n = 0 -> [[]]
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)]
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
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
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
1241 let head = List.head
1242 let opthead = List.opthead
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
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
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'
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)
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
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)
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
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
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
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 *)
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
1443 (* #load "Str.cma";; *)
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
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 *)
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
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