(* This version from 1 April 2015 *)
module Juli8 = struct
(*
module Std = struct
include Pervasives
module List = List
end
*)
external ident : 'a -> 'a = "%identity"
let const c = (); fun _ -> c
(* TODO: include fun x y -> f (g x y)? include flip (%)? *)
let (%) f g = (); fun x -> f (g x)
let flip f = (); fun x y -> f y x
let fix (f : ('a -> 'b) -> ('a -> 'b)) : 'a -> 'b = let rec x y = f x y in x
(* Haskell's `(op rightval)` = `flip (op) rightval` *)
(* Haskell's `f $ xxx $ yyy` == `f @@ xxx @@ yyy` which is properly right-associative.
If you `let ($$) = (@@)`, then `f $$ xxx $$ yyy` will be `f (xxx) (yyy)`. *)
(* `non p` == `not % p` *)
let non f = (); fun x -> not (f x)
let non2 f = (); fun x y -> not (f x y)
let pair x y = (x, y)
let swap (x, y) = (y, x)
let curry f = (); fun x y -> f (x, y)
let uncurry f = (); fun (x, y) -> f x y
let mapfst f (x, y) = (f x, y)
let mapsnd f (x, y) = (x, f y)
let even x = x land 1 = 0
let odd x = x land 1 = 1
let sign x = if x < 0 then -1 else if x > 0 then 1 else 0
exception Overflow
let pred x = if x < 0 then invalid_arg "pred" else if x > 0 then x - 1 else raise Overflow
let pred' x = if x < 0 then invalid_arg "pred'" else if x > 0 then x - 1 else 0
let sub x y = if x < 0 || y < 0 then invalid_arg "sub" else if x >= y then x - y else raise Overflow
let sub' x y = if x < 0 || y < 0 then invalid_arg "sub'" else if x >= y then x - y else 0
let mid x y = x land y + ((x lxor y) asr 1)
let pow (x : int) (n : int) : int =
let rec aux x n =
if n = 1 then x
else
let y = aux x (n asr 1) in
y * y * (if n land 1 = 0 then 1 else x) in
if n < 0 then invalid_arg "pow"
else if n = 0 then 1
else aux x n
let undefined () = failwith "undefined"
let finally handler f x =
let res = (try f x with e -> handler(); raise e) in
handler(); res
(* Haskell's `last $ take n $ iterate s z`, might also call `ntimes` *)
let rec iterate (n : int) s z =
if n <= 0 then z
else iterate (n - 1) s (s z)
(* Haskell's `head $ dropWhile p $ iterate s z`; or `until (not.p) s z` *)
let rec iter_while p s z =
if p z then iter_while p s (s z) else z
(* let forever f x = while true do f x done *)
let rec forever f x = ignore(f x); forever f x
module Option : sig
val some : 'a -> 'a option
val test : ('a -> bool) -> 'a -> 'a option
val is_some : 'a option -> bool
val is_none : 'a option -> bool
val unsome : exn -> 'a option -> 'a (* Haskell's `fromJust` *)
val optcatch : ('a -> 'b) -> 'a -> 'b option
val string_of_option : ('a -> string) -> 'a option -> string
val list_of_option : 'a option -> 'a list (* Haskell's `maybeToList` *)
(* List.opthead is Haskell's `listToMaybe` *)
val default : 'a -> 'a option -> 'a (* Haskell's `fromMaybe` *)
val mapdefault : 'b -> ('a -> 'b) -> 'a option -> 'b (* Haskell's `maybe` *)
(* List.optmap is Haskell's `mapMaybe` *)
val length : 'a option -> int
val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a option -> bool
val map : ('a -> 'b) -> 'a option -> 'b option
val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option
val filter : ('a -> bool) -> 'a option -> 'a option
end = struct
let some x = Some x
let test p x = if p x then Some x else None
let is_some = function Some _ -> true | _ -> false
let is_none = function None -> true | _ -> false
let unsome exn = function Some a -> a | None -> raise exn
let optcatch f a = try Some (f a) with _ -> None
let string_of_option f = function Some a -> "Some " ^ f a | None -> "None"
let list_of_option = function Some a -> [a] | None -> []
let default def = function Some a -> a | None -> def
let mapdefault def f = function Some a -> f a | None -> def
let length = function Some _ -> 1 | None -> 0
let mem ?(eq=(=)) sought = function Some y -> eq y sought | None -> false
let map f = function Some a -> Some (f a) | None -> None
let map2 f u v = match u,v with Some x,Some y -> Some (f x y) | _ -> None
let filter p = function Some a as orig when p a -> orig | _ -> None
end
let some = Option.some
let is_some = Option.is_some
let is_none = Option.is_none
let unsome = Option.unsome
let string_of_option = Option.string_of_option
let list_of_option = Option.list_of_option
module List : sig
(*
Some functions in this module accept labels: ~short, ~onto:_, ~rev, ~cmp:_, ~eq:_, ~missing:_, ~step:_, ~many, ~len:_.
~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)
~onto:[] is for efficiency (rev, map, mapi, map2, zip, unmap2, unzip, optmap, optmapi, catmap, catmapi, filter, unfold, mapz).
~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.
For sort and is_sorted, ~rev reverses the direction of ~cmp (first match will still come first/be retained if not ~many).
~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.
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.
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.
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.
Functions seeking a specific member/key may specify the ~eq:(=) function (mem, index, delete, indices, assoc, mem_assoc, [opt]modify_assoc, remove_assoc).
Other functions using ~eq: group, [is_]unique, is_eqset, is_subset/list, diff, union, intersect, histogram.
See also memq, indexq, deleteq, indicesq, assq, mem_assq, [opt]modify_assq, remove_assq.
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.
Additionally, range and range_until accept ~step, and range's second argument can be tagged ~len.
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.
sublists and permutations accept optional ~len, and can also be invoked as ~len:_ ~many to mean with replacement.
Functions in this module may raise:
* Invalid_argument for indices < 0, or length < 0 for make, or ~step:0 for range/_until
* Invalid argument when specifying both ~cmp and ~rev to index, delete; or both ~many and ~rev to remove, delete.
* Invalid_argument when is_subset without ~cmp or ~many; or when sublists/permutations ~many without ~len
* Not_found
* Short_list, e.g. head []; map2 f [] [...] without ~short; indices >= length
Primed versions of tail, init, take, drop, split: silently accommodate short lists. (Compare pred', sub'.)
*)
(* TODO: cycle n xs *)
(* IFFY names: unmap2, mapz, min/maxby, chunk[']/chunk_int/chunk_range, is_eqset, indexq/indicesq/deleteq *)
val short : unit
val many : unit
exception Short_list
val is_null : 'a list -> bool
val length : 'a list -> int
val count : ('a -> bool) -> 'a list -> int
val cons : 'a -> 'a list -> 'a list
val snoc : 'a list -> 'a -> 'a list
val singleton : 'a -> 'a list
val make : int -> 'a -> 'a list (* Haskell's `replicate` *)
val head : 'a list -> 'a
val opthead : 'a list -> 'a option
val tail : 'a list -> 'a list
val tail' : 'a list -> 'a list
val uncons : 'a list -> 'a * 'a list
val last : 'a list -> 'a
val init : 'a list -> 'a list
val init' : 'a list -> 'a list
val append : 'a list -> 'a list -> 'a list
val concat : 'a list list -> 'a list
val rev : ?onto:'a list -> 'a list -> 'a list (* Haskell's `reverse` *)
val mem : 'a -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> bool (* Haskell's `elem` *)
val map : ('a -> 'b) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list
val map2 : ('a -> 'b -> 'c) -> ?rev:'d -> ?onto:'c list -> ?short:'e -> 'a list -> 'b list -> 'c list (* Haskell's `zipWith` *)
val unmap2 : ('c -> 'a * 'b) -> ?rev:'d -> ?onto:'a list * 'b list -> 'c list -> 'a list * 'b list
val zip : ?rev:'d -> ?onto:('a * 'b) list -> ?short:'e -> 'a list -> 'b list -> ('a * 'b) list (* aka `Std.List.combine` or `map2 pair` *)
val unzip : ?rev:'d -> ?onto:'b list * 'c list -> ('b * 'c) list -> 'b list * 'c list (* aka `Std.List.split` or `unmap2 ident` *)
val mapi : (int -> 'a -> 'b) -> ?onto:'b list -> 'a list -> 'b list
val optmap : ('a -> 'b option) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list
val optmapi : (int -> 'a -> 'b option) -> ?onto:'b list -> 'a list -> 'b list
(* `catmap f ~rev [x1,x2,x3]` ==> [x3c..x3a; x2c..x2a; x1c..x1a] *)
val catmap : ('a -> 'b list) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list (* Haskell's `concatMap` *)
val catmapi : (int -> 'a -> 'b list) -> ?onto:'b list -> 'a list -> 'b list
val iter : ('a -> unit) -> 'a list -> unit
val iteri : (int -> 'a -> unit) -> 'a list -> unit
val iter2 : ('a -> 'b -> unit) -> ?short:'c -> 'a list -> 'b list -> unit
val fold_left : ('z -> 'a -> 'z) -> 'z -> 'a list -> 'z
val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a
val fold_left2 : ('z -> 'a -> 'b -> 'z) -> 'z -> ?short:'d -> 'a list -> 'b list -> 'z
val fold_right : ('a -> 'z -> 'z) -> 'a list -> 'z -> 'z
val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a
val fold_right2 : ('a -> 'b -> 'z -> 'z) -> ?short:'d -> 'a list -> 'b list -> 'z -> 'z
val for_all : ('a -> bool) -> 'a list -> bool (* Haskell's `all` *)
val exists : ('a -> bool) -> 'a list -> bool (* Haskell's `any` *)
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val maximum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a
val minimum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a
(* These compare mapped values, and return index,original,mapped value. *)
val maxby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b
val minby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b
val sum : int list -> int
val product : int list -> int
val take : int -> 'a list -> 'a list
val take' : int -> 'a list -> 'a list
val drop : int -> 'a list -> 'a list (* `tail` is `drop 1` *)
val drop' : int -> 'a list -> 'a list
val split : int -> 'a list -> 'a list * 'a list
val split' : int -> 'a list -> 'a list * 'a list (* Haskell's `splitAt` *)
val nth : 'a list -> int -> 'a (* Haskell's `xs !! n` *)
val modify : int -> ('a -> 'a) -> 'a list -> 'a list
val optmodify : int -> ('a -> 'a option) -> 'a list -> 'a list
val catmodify : int -> ('a -> 'a list) -> 'a list -> 'a list
val take_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list
val drop_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list
(* `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)` *)
val split_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list * 'a list (* Haskell's `span` *)
val find : ('a -> bool) -> ?rev:'b -> 'a list -> 'a
val optfind : ('a -> 'b option) -> ?rev:'c -> 'a list -> 'b
val findx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a (* fst of this is Haskell's `findIndex`, except that returns Maybe Int *)
(* Unlike findx, index accepts ~cmp. *)
val index : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> int (* Haskell's `elemIndex`, except that returns Maybe Int *)
val remove : ('a -> bool) -> ?rev:'b -> ?many:'c -> 'a list -> 'a list
val delete : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> ?many:'c -> 'a list -> 'a list
(* `pick p xs` is `(find p xs, remove p xs)` *)
val pick : ('a -> bool) -> ?rev:'b -> 'a list -> 'a * 'a list
val pickx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a * 'a list
val filter : ('a -> bool) -> ?rev:'b -> ?onto:'a list -> 'a list -> 'a list
val filterx : ('a -> bool) -> 'a list -> (int * 'a) list (* fst of this is Haskell's `findIndices` *)
val indices : 'a -> ?eq:('a -> 'a -> bool) -> 'a list -> int list (* Haskell's `elemIndices` *)
(* `partition p xs` is `(filter p xs, filter (non p) xs)` *)
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
val partitionx : ('a -> bool) -> 'a list -> (int * 'a) list * (int * 'a) list
val assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> 'b (* Haskell's `lookup` *)
val mem_assoc : 'a -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> bool
val modify_assoc : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list
val optmodify_assoc : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list
val remove_assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list
val memq : 'a -> 'a list -> bool
val indexq : 'a -> 'a list -> int
val deleteq : 'a -> 'a list -> 'a list
val indicesq : 'a -> 'a list -> int list
val assq : 'a -> ?rev:'c -> ('a * 'b) list -> 'b
val mem_assq : 'a -> ('a * 'b) list -> bool
val modify_assq : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list
val optmodify_assq : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list
val remove_assq : 'a -> ?rev:'c -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list
(* Positive n rotates forward; `rotate 1 xs` is `append (last xs) (init xs)` or `unsnoc` *)
val rotate : int -> 'a list -> 'a list
val unfold : ('z -> ('a * 'z) option) -> ?rev:'c -> ?onto:'a list -> 'z -> 'a list
(* ~rev only affects the order of the mapz'd output, not the direction of the folding *)
val mapz : ('z -> 'a -> 'z * 'b) -> 'z -> ?rev:'d -> ?onto:'b list -> 'a list -> 'z * 'b list (* Haskell's `mapAccumL` *)
val group : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list list (* Haskell's `groupBy` *)
(* `cross f xs ys` is `[f x y | x from xs, y from ys]` or `catmap (fun x -> map (f x) ys) xs` *)
val cross : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(* `insert` expects a sorted list; use `catmodify` to insert elements before/after a specified index *)
val insert : 'a -> ?cmp:('a -> 'a -> int) -> ?many:'b -> 'a list -> 'a list
(* Plural version of `nth` *)
val select : 'a list -> int list -> 'a list
(* `range start ~len` *)
val range : ?step:int -> int -> len:int -> int list
(* `range_until start excluded_stop`; specify ~step:1 to produce [] when stop < start *)
val range_until : ?step:int -> int -> int -> int list
val unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list (* Haskell's `nub` *)
val is_unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> bool
(* `transpose [xxx, yyy]` ==> [xy, xy, xy] *)
val transpose : 'a list list -> 'a list list
(* Based on http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/Data-List.html#permutations
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)` *)
val permutations : ?len:int -> ?many:'b -> 'a list -> 'a list list
(* `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`.
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
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 *)
val sublists : ?len:int -> ?many:'b -> 'a list -> 'a list list
(* 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 *)
val is_sublist : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool
(* `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 *)
val is_subset : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> bool
(* Multiset equality, order ignored *)
val is_eqset : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool
val lexcmp : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
(* `diff ~many xs ys` deletes all occurrences of each member of ys *)
val diff : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> 'a list
(* Each element has its max multiplicity; with second list always as a suffix of the result *)
val union : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
(* Each element has its min multiplicity; in order of second list *)
val intersect : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
(* To merge without ~many, use `union ~cmp:compare`. *)
val merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
(* Stable mergesort, O(n log n) avg and worst, will delete later occurrences of any duplicates, unless invoked with ~many *)
val sort : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> 'a list
val is_sorted : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> bool
val string_of_list : ?brackets:bool -> ?sep:string -> ('a -> string) -> 'a list -> string
val histogram : ?eq:('a -> 'a -> bool) -> 'a list -> ('a * int) list
(* [x1;x2;x3] ==> [(x1,x2);(x2,x3);(x3,missing)] *)
val pairwise : ?missing:'a -> 'a list -> ('a * 'a) list
(* [xxxx,y,zz] ==> xyzxzxx *)
val round_robin : 'a list list -> 'a list
(* Break list into int-sized discrete segments; chunk' permits last chunk to be short *)
val chunk : int -> 'a list -> 'a list list
val chunk' : int -> 'a list -> 'a list list
(* How many ways can int be represented as sum of members of xs (permitting them to be re-used)?
`chunk_int 6 [1;2;3]` ==> [ [3;3]; [3;2;1]; [3;1;1;1]; ...]
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. *)
val chunk_int : int -> int list -> int list list
(* Partitions of the range 0..(k1+k2+k3) into lists of size k1,k2,k3.
`chunk_range [2;1;3]` ==> [ [[0;1];[2];[3;4;5]]; ...]
Based on http://rosettacode.org/wiki/Ordered_Partitions#Haskell *)
val chunk_range : int list -> int list list list
end = struct
let short = ()
let many = ()
exception Short_list
let is_null = function [] -> true | _ -> false
let length xs =
let rec aux i = function [] -> i | _::xs -> aux (i+1) xs in
aux 0 xs
let count p xs =
let rec aux p n = function [] -> n | x::xs when p x -> aux p (n+1) xs | _::xs -> aux p n xs in
aux p 0 xs
let cons x xs = x :: xs
let singleton x = [x]
let make n x =
let rec aux x xs n = if n = 0 then xs else aux x (x::xs) (n-1) in
if n < 0 then invalid_arg "make" else aux x [] n
let rec rev1 onto = function [] -> onto | x::xs -> rev1 (x::onto) xs
let rec rev2 onto = function [] -> onto | ys::yss -> rev2 (rev1 onto ys) yss
let rec rev ?(onto=[]) = function [] -> onto | x::xs -> let onto = x::onto in rev ~onto xs
let snoc xs x = rev1 [x] (rev1 [] xs)
let head = function x::_ -> x | [] -> raise Short_list
let opthead = function x::_ -> Some x | [] -> None
let tail = function _::xs -> xs | [] -> raise Short_list
let tail' = function _::xs -> xs | [] -> []
let uncons = function x::xs -> (x,xs) | [] -> raise Short_list
let rec last = function [x] -> x | x::xs -> last xs | _ -> raise Short_list
let init xs = match rev1 [] xs with [] -> raise Short_list | _::xs -> rev1 [] xs
let init' xs = match rev1 [] xs with [] -> [] | _::xs -> rev1 [] xs
let append xs = function [] -> xs | onto -> rev1 onto (rev1 [] xs)
let concat xss = rev2 [] (rev1 [] xss)
let mem sought ?(eq=(=)) ?cmp xs =
let rec aux_all eq sought = function [] -> false | x::xs -> eq x sought || aux_all eq sought xs in
let rec aux_sorted cmp sought = function
| x::xs -> let res = cmp x sought in if res > 0 then false else res = 0 || aux_sorted cmp sought xs
| [] -> false in
match cmp with
| None -> aux_all eq sought xs
| Some cmp -> aux_sorted cmp sought xs
let rec memq sought = function [] -> false | x::xs -> x == sought || memq sought xs
let map f ?rev ?(onto=[]) xs =
let rec aux f onto = function
| [] -> onto
| x::xs -> aux f (f x::onto) xs in
match rev with
| None -> rev1 onto (aux f [] xs)
| Some _ -> aux f onto xs
let map2 f ?rev ?(onto=[]) ?short xs ys =
let rec aux f short onto xs ys = match xs, ys with
| x::xs, y::ys -> aux f short (f x y::onto) xs ys
| [],[] -> onto
| _ -> if short then onto else raise Short_list in
match rev with
| None -> rev1 onto (aux f (Option.is_some short) [] xs ys)
| Some _ -> aux f (Option.is_some short) onto xs ys
let zip ?rev ?(onto=[]) ?short xs ys =
let rec aux short onto xs ys = match xs, ys with
| x::xs, y::ys -> aux short ((x,y)::onto) xs ys
| [],[] -> onto
| _ -> if short then onto else raise Short_list in
match rev with
| None -> rev1 onto (aux (Option.is_some short) [] xs ys)
| Some _ -> aux (Option.is_some short) onto xs ys
let unmap2 f ?rev ?(onto=[],[]) zs =
let rec aux f xs ys = function
| [] -> xs, ys
| z::zs -> let x,y = f z in aux f (x::xs) (y::ys) zs in
match rev,onto with
| None,(xonto,yonto) -> let xs,ys = aux f [] [] zs in rev1 xonto xs, rev1 yonto ys
| Some _,(xonto,yonto) -> aux f xonto yonto zs
let unzip ?rev ?(onto=[],[]) zs =
let rec aux xs ys = function
| [] -> xs, ys
| (x,y)::zs -> aux (x::xs) (y::ys) zs in
match rev,onto with
| None,(xonto,yonto) -> let xs,ys = aux [] [] zs in rev1 xonto xs, rev1 yonto ys
| Some _,(xonto,yonto) -> aux xonto yonto zs
let mapi f ?(onto=[]) xs =
let rec aux f i onto = function
| [] -> onto
| x::xs -> aux f (i+1) (f i x::onto) xs in
rev1 onto (aux f 0 [] xs)
let optmap f ?rev ?(onto=[]) xs =
let rec aux f onto = function
| [] -> onto
| x::xs -> aux f (match f x with None -> onto | Some x' -> x'::onto) xs in
match rev with
| None -> rev1 onto (aux f [] xs)
| Some _ -> aux f onto xs
let optmapi f ?(onto=[]) xs =
let rec aux f i onto = function
| [] -> onto
| x::xs -> aux f (i+1) (match f i x with None -> onto | Some x' -> x'::onto) xs in
rev1 onto (aux f 0 [] xs)
let catmap f ?rev ?(onto=[]) xs =
let rec aux f onto = function
| [] -> onto
| x::xs -> aux f (rev1 [] (f x)::onto) xs in
let rec aux_rev f onto = function
| [] -> onto
| x::xs -> aux_rev f (rev1 onto (f x)) xs in
match rev with
| None -> rev2 onto (aux f [] xs)
| Some _ -> aux_rev f onto xs
let catmapi f ?(onto=[]) xs =
let rec aux f i onto = function
| [] -> onto
| x::xs -> aux f (i+1) (rev1 [] (f i x)::onto) xs in
rev2 onto (aux f 0 [] xs)
let rec iter f = function [] -> () | x::xs -> f x; iter f xs
let iteri f xs =
let rec aux f i = function [] -> () | x::xs -> f i x; aux f (i+1) xs in
aux f 0 xs
let iter2 f ?short xs ys =
let rec aux f short xs ys = match xs, ys with
| x::xs, y::ys -> f x y; aux f short xs ys
| [],[] -> ()
| _ -> if short then () else raise Short_list in
aux f (Option.is_some short) xs ys
let rec fold_left f z = function
| [] -> z
| x::xs -> fold_left f (f z x) xs
let fold_left1 f = function
| [] -> raise Short_list
| x::xs -> fold_left f x xs
let fold_left2 f z ?short xs ys =
let rec aux f short z xs ys = match xs, ys with
| [],[] -> z
| x::xs,y::ys -> aux f short (f z x y) xs ys
| _ -> if short then z else raise Short_list in
aux f (Option.is_some short) z xs ys
let rec fold_right f xs z =
let rec aux f z = function
| [] -> z
| x::xs -> aux f (f x z) xs in
aux f z (rev1 [] xs)
let fold_right1 f xs =
let rec aux f z = function
| [] -> z
| x::xs -> aux f (f x z) xs in
match rev1 [] xs with
| [] -> raise Short_list
| x::xs -> aux f x xs
let fold_right2 f ?short xs ys z =
let rec aux f short z xs ys = match xs, ys with
| [],[] -> z
| x::xs,y::ys -> aux f short (f x y z) xs ys
| _ -> if short then z else raise Short_list in
aux f (Option.is_some short) z (rev1 [] xs) (rev1 [] ys)
let rec for_all p = function [] -> true | x::xs -> p x && for_all p xs
let rec exists p = function [] -> false | x::xs -> p x || exists p xs
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
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
let maximum ?rev ?(cmp=compare) xs =
let rec aux select cmp sofar = function
| [] -> sofar
| 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
match rev,xs with
| None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs
| Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs
| _ -> raise Short_list
let minimum ?rev ?(cmp=compare) xs =
let rec aux select cmp sofar = function
| [] -> sofar
| 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
match rev,xs with
| None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs
| Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs
| _ -> raise Short_list
(*
let maximumx ?rev ?(cmp=compare) xs =
let rec aux select cmp i sofar = function
| [] -> sofar
| 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
match rev,xs with
| None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs
| Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs
| _ -> raise Short_list
let minimumx ?rev ?(cmp=compare) xs =
let rec aux select cmp i sofar = function
| [] -> sofar
| 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
match rev,xs with
| None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs
| Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs
| _ -> raise Short_list
*)
let maxby f ?(cmp=compare) ?rev xs =
let rec aux f cmp thresh (_,_,fw as prev) i = function
| [] -> prev
| 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
match rev,xs with
| _,[] -> raise Short_list
| None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs
| Some _,x::xs -> aux f cmp (-1) (0,x,f x) 1 xs
let minby f ?(cmp=compare) ?rev xs =
let rec aux f cmp thresh (_,_,fw as prev) i = function
| [] -> prev
| 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
match rev,xs with
| _,[] -> raise Short_list
| None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs
| Some _,x::xs -> aux f cmp (+1) (0,x,f x) 1 xs
let sum xs = fold_left ( + ) 0 xs
let product xs = fold_left ( * ) 1 xs
let take n xs =
let rec aux n ys = function
| _ when n = 0 -> rev1 [] ys
| [] -> raise Short_list
| x::xs -> aux (n-1) (x::ys) xs in
if n < 0 then invalid_arg "take" else aux n [] xs
let take' n xs =
let rec aux n ys = function
| _ when n = 0 -> rev1 [] ys
| [] -> rev1 [] ys
| x::xs -> aux (n-1) (x::ys) xs in
if n < 0 then invalid_arg "take'" else aux n [] xs
let drop n xs =
let rec aux n = function
| xs when n = 0 -> xs
| [] -> raise Short_list
| _::xs -> aux (n-1) xs in
if n < 0 then invalid_arg "drop" else aux n xs
let drop' n xs =
let rec aux n = function
| xs when n = 0 -> xs
| [] -> []
| _::xs -> aux (n-1) xs in
if n < 0 then invalid_arg "drop'" else aux n xs
let split n xs =
let rec aux n ys = function
| xs when n = 0 -> rev1 [] ys, xs
| [] -> raise Short_list
| x::xs -> aux (n-1) (x::ys) xs in
if n < 0 then invalid_arg "split" else aux n [] xs
let split' n xs =
let rec aux n ys = function
| xs when n = 0 -> rev1 [] ys, xs
| [] -> rev1 [] ys, []
| x::xs -> aux (n-1) (x::ys) xs in
if n < 0 then invalid_arg "split'" else aux n [] xs
let nth xs n =
let rec aux n = function
| x::xs -> if n = 0 then x else aux (n-1) xs
| [] -> raise Short_list in
if n < 0 then invalid_arg "nth" else aux n xs
let modify n f xs =
let rec aux n f i ys = function
| [] -> raise Short_list
| x::xs -> if n = i then rev1 ((f x)::xs) ys else aux n f (i+1) (x::ys) xs in
if n < 0 then invalid_arg "modify" else aux n f 0 [] xs
let optmodify n f xs =
let rec aux n f i ys = function
| [] -> raise Short_list
| 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
if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs
let catmodify n f xs =
let rec aux n f i ys = function
| [] -> raise Short_list
| x::xs -> if n = i then rev1 xs (rev1 ys (f x)) else aux n f (i+1) (x::ys) xs in
if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs
let take_while p ?rev xs =
let rec aux_left p ys = function
| [] -> xs
| x::xs -> if p x then aux_left p (x::ys) xs else rev1 [] ys in
let rec aux_right p ys = function
| [] -> rev1 [] ys
| x::xs -> if p x then aux_right p (x::ys) xs else aux_right p [] xs in
match rev with
| None -> aux_left p [] xs
| Some _ -> aux_right p [] xs
let drop_while p ?rev xs =
let rec aux_left p = function
| [] -> []
| x::xs as orig -> if p x then aux_left p xs else orig in
let rec aux_right p matching yss ys = function
| [] -> if matching then rev2 [] yss else xs
| x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs
else aux_right p (not matching) (ys::yss) [x] xs in
match rev with
| None -> aux_left p xs
| Some _ -> aux_right p false [] [] xs
let split_while p ?rev xs =
let rec aux_left p ys = function
| [] -> xs, []
| x::xs as orig -> if p x then aux_left p (x::ys) xs else rev1 [] ys, orig in
let rec aux_right p matching yss ys = function
| [] -> if matching then rev2 [] yss, rev1 [] ys else xs, []
| x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs
else aux_right p (not matching) (ys::yss) [x] xs in
match rev with
| None -> aux_left p [] xs
| Some _ -> aux_right p false [] [] xs
let find p ?rev xs =
let rec aux_left p = function [] -> raise Not_found | x::xs -> if p x then x else aux_left p xs in
let rec aux_right p prev = function
| [] -> (match prev with None -> raise Not_found | Some x -> x)
| x::xs -> aux_right p (if p x then Some x else prev) xs in
match rev with
| None -> aux_left p xs
| Some _ -> aux_right p None xs
let optfind p ?rev xs =
let rec aux_left p = function [] -> raise Not_found | x::xs -> (match p x with Some y -> y | None -> aux_left p xs) in
let rec aux_right p prev = function
| [] -> (match prev with None -> raise Not_found | Some x -> x)
| x::xs -> aux_right p (match p x with Some y -> Some y | None -> prev) xs in
match rev with
| None -> aux_left p xs
| Some _ -> aux_right p None xs
let findx p ?rev xs =
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
let rec aux_right p i prev = function
| [] -> (match prev with None -> raise Not_found | Some (i,x as res) -> res)
| x::xs -> aux_right p (i+1) (if p x then Some (i,x) else prev) xs in
match rev with
| None -> aux_left p 0 xs
| Some _ -> aux_right p 0 None xs
let index sought ?rev ?(eq=(=)) ?cmp xs =
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
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
let rec aux_sorted cmp sought i = function
| 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
| [] -> raise Not_found in
match cmp,rev with
| None,None -> aux_left eq sought 0 xs
| None,Some _ -> aux_right eq sought 0 (-1) xs
| Some cmp,None -> aux_sorted cmp sought 0 xs
| Some _,Some _ -> invalid_arg "index ~rev conflicts with ~cmp"
let indexq sought xs =
let rec aux sought i = function [] -> raise Not_found | x::xs -> if x == sought then i else aux sought (i+1) xs in
aux sought 0 xs
let remove p ?rev ?many xs =
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
let rec aux_many p ys = function [] -> rev1 [] ys | x::xs -> aux_many p (if p x then ys else x::ys) xs in
let rec aux_right p yss ys = function
| [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| x::xs -> if p x then aux_right p ((x::ys)::yss) [] xs else aux_right p yss (x::ys) xs in
match rev,many with
| None,None -> aux_left p [] xs
| Some _,None -> aux_right p [] [] xs
| None,Some _ -> aux_many p [] xs
| Some _,Some _ -> invalid_arg "remove ~rev conflicts with ~many"
let delete sought ?rev ?(eq=(=)) ?cmp ?many xs =
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
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
let rec aux_right eq sought yss ys = function
| [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| 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
let rec aux_sorted cmp sought ys = function
| [] -> xs
(* don't shadow the entry-level `xs` *)
| 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
let rec aux_msorted cmp sought ys = function
| [] -> rev1 [] ys
| 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
match cmp,rev,many with
| None,None,None -> aux_left eq sought [] xs
| None,Some _,None -> aux_right eq sought [] [] xs
| Some cmp,None,None -> aux_sorted cmp sought [] xs
| None,None,Some _ -> aux_many eq sought [] xs
| Some cmp,None,Some _ -> aux_msorted cmp sought [] xs
| Some _,Some _,None -> invalid_arg "delete ~rev conflicts with ~cmp"
| None,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many"
| Some _,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many and ~cmp"
let deleteq sought xs =
let rec aux sought ys = function [] -> xs | x::xs -> if x == sought then rev1 xs ys else aux sought (x::ys) xs in
aux sought [] xs
let pick p ?rev xs =
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
let rec aux_right p prev yss ys = function
| [] -> (match prev, yss with None,_ -> raise Not_found | Some x,(_::xs)::yss -> x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| 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
match rev with
| None -> aux_left p [] xs
| Some _ -> aux_right p None [] [] xs
let pickx p ?rev xs =
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
let rec aux_right p i prev yss ys = function
| [] -> (match prev, yss with None,_ -> raise Not_found | Some (i,x),(_::xs)::yss -> i, x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| 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
match rev with
| None -> aux_left p 0 [] xs
| Some _ -> aux_right p 0 None [] [] xs
let filter p ?rev ?(onto=[]) xs =
let rec aux p ys = function [] -> ys | x::xs -> aux p (if p x then x::ys else ys) xs in
match rev with
| None -> rev1 onto (aux p [] xs)
| Some _ -> aux p onto xs
(*
val filteri : (int -> 'a -> bool) -> ?onto:'a list -> 'a list -> 'a list
let filteri p ?(onto=[]) xs =
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
rev1 onto (aux p 0 [] xs)
*)
let filterx p xs =
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
rev1 [] (aux p 0 [] xs)
let indices sought ?(eq=(=)) xs =
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
rev1 [] (aux eq sought 0 [] xs)
let indicesq sought xs =
let rec aux sought i ys = function [] -> ys | x::xs -> aux sought (i+1) (if x == sought then i::ys else ys) xs in
rev1 [] (aux sought 0 [] xs)
(* remove ~many p, delete ~many x *)
let partition p xs =
let rec aux p ys ns = function
| [] -> if ys = [] then [], xs else if ns = [] then xs, [] else rev1 [] ys, rev1 [] ns
| x::xs -> if p x then aux p (x::ys) ns xs else aux p ys (x::ns) xs in
aux p [] [] xs
let partitionx p xs =
let rec aux p i ys ns = function
| [] -> rev1 [] ys, rev1 [] ns
| 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
aux p 0 [] [] xs
let assoc sought ?rev ?(eq=(=)) xs =
let rec aux_left sought eq = function
| [] -> raise Not_found
| (k,x)::xs -> if eq k sought then x else aux_left sought eq xs in
let rec aux_right sought eq prev = function
| [] -> (match prev with None -> raise Not_found | Some x -> x)
| (k,x)::xs -> aux_right sought eq (if eq k sought then Some x else prev) xs in
match rev with
| None -> aux_left sought eq xs
| Some _ -> aux_right sought eq None xs
let rec assq sought ?rev xs =
let rec aux_left sought = function
| [] -> raise Not_found
| (k,x)::xs -> if k == sought then x else assq sought xs in
let rec aux_right sought prev = function
| [] -> (match prev with None -> raise Not_found | Some x -> x)
| (k,x)::xs -> aux_right sought (if k == sought then Some x else prev) xs in
match rev with
| None -> aux_left sought xs
| Some _ -> aux_right sought None xs
let modify_assoc sought f ?missing ?rev ?(eq=(=)) xs =
let rec aux_left sought f eq ys = function
| [] -> None
| (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
let rec aux_right sought f eq yss ys = function
| [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
| (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
match rev,missing with
| None,None -> (match aux_left sought f eq [] xs with None -> raise Not_found | Some xs -> xs)
| None,Some m -> (match aux_left sought f eq [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
| Some _,None -> (match aux_right sought f eq [] [] xs with None -> raise Not_found | Some xs -> xs)
| Some _,Some m -> (match aux_right sought f eq [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
let optmodify_assoc sought f ?rev ?(eq=(=)) xs =
let rec aux_left sought f eq ys = function
| [] -> None
| (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
let rec aux_right sought f eq yss ys = function
| [] -> (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)
| (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
match rev with
| 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)
| 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)
let modify_assq sought f ?missing ?rev xs =
let rec aux_left sought f ys = function
| [] -> None
| (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
let rec aux_right sought f yss ys = function
| [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false)
| (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
match rev,missing with
| None,None -> (match aux_left sought f [] xs with None -> raise Not_found | Some xs -> xs)
| None,Some m -> (match aux_left sought f [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
| Some _,None -> (match aux_right sought f [] [] xs with None -> raise Not_found | Some xs -> xs)
| Some _,Some m -> (match aux_right sought f [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs)
let optmodify_assq sought f ?rev xs =
let rec aux_left sought f ys = function
| [] -> None
| (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
let rec aux_right sought f yss ys = function
| [] -> (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)
| (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
match rev with
| None -> (match aux_left sought f [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
| Some _ -> (match aux_right sought f [] [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs)
let rec mem_assoc sought ?(eq=(=)) = function
| [] -> false
| (k,_)::xs -> eq k sought || mem_assoc ~eq sought xs
let rec mem_assq sought = function
| [] -> false
| (k,_)::xs -> k == sought || mem_assq sought xs
let remove_assoc sought ?rev ?(eq=(=)) ?many xs =
let rec aux_left sought eq ys = function
| [] -> xs
| (k,_ as kx)::xs -> if eq k sought then rev1 xs ys else aux_left sought eq (kx::ys) xs in
let rec aux_many sought eq ys = function
| [] -> rev1 [] ys
| (k,_ as kx)::xs -> aux_many sought eq (if eq k sought then ys else kx::ys) xs in
let rec aux_right sought eq yss ys = function
| [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| (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
match rev,many with
| None,None -> aux_left sought eq [] xs
| Some _,None -> aux_right sought eq [] [] xs
| None,Some _ -> aux_many sought eq [] xs
| Some _,Some _ -> invalid_arg "remove_assoc ~rev conflicts with ~many"
let remove_assq sought ?rev ?many xs =
let rec aux_left sought ys = function
| [] -> xs
| (k,_ as kx)::xs -> if k == sought then rev1 xs ys else aux_left sought (kx::ys) xs in
let rec aux_many sought ys = function
| [] -> rev1 [] ys
| (k,_ as kx)::xs -> aux_many sought (if k == sought then ys else kx::ys) xs in
let rec aux_right sought yss ys = function
| [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false)
| (k,_ as kx)::xs -> if k == sought then aux_right sought ((kx::ys)::yss) [] xs else aux_right sought yss (kx::ys) xs in
match rev,many with
| None,None -> aux_left sought [] xs
| Some _,None -> aux_right sought [] [] xs
| None,Some _ -> aux_many sought [] xs
| Some _,Some _ -> invalid_arg "remove_assq ~rev conflicts with ~many"
let rotate n xs =
let rec aux ys = function
| [x] -> x::rev1 [] ys
| x::xs -> aux (x::ys) xs
| _ -> assert false in
if n = 0 || xs = [] then xs
else if n = 1 then aux [] xs
else
let xn = length xs in
let n = (xn - n) mod xn in
let pre,post = if n > 0 then split n xs else if n < 0 then split (xn+n) xs else [],xs in
append post pre
let unfold f ?rev ?(onto=[]) z =
let rec aux f ys z = match f z with None -> ys | Some (y,z) -> aux f (y::ys) z in
match rev with
| None -> rev1 onto (aux f [] z)
| Some _ -> aux f onto z
let mapz f z ?rev ?(onto=[]) xs =
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
match rev with
| None -> let z,ys = aux f z [] xs in z, rev1 onto ys
| Some _ -> aux f z onto xs
(*
let group ?(eq=(=)) xs =
let rec aux eq = function
| [] -> []
| x::xs -> let xs,ys = split_while (eq x) xs in (x::xs)::aux eq ys in
aux eq xs
*)
let group ?(eq=(=)) xs =
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
let rec aux f eq yss = function [] -> yss | x::xs -> aux f eq (f eq x yss) xs in
match aux f eq [] xs with [] -> [] | xs -> map ~rev rev xs
let cross f xs ys =
let rec aux f ys = function [] -> ys | x::xs -> aux f (f x::ys) xs in
rev2 [] (aux (fun x -> aux (f x) [] ys) [] xs)
let insert ins ?(cmp=compare) ?many xs =
let rec aux_one cmp ins ys = function
| [] -> rev1 [ins] ys
(* don't shadow the entry-level `xs` *)
| 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
let rec aux_many cmp ins ys = function
| [] -> rev1 [ins] ys
| 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
match many with
| None -> aux_one cmp ins [] xs
| Some _ -> aux_many cmp ins [] xs
let select xs is =
let rec aux j js i ys = function
| [] -> raise Short_list
(* don't shadow the entry-level `xs` *)
| 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
match is with
| [] -> []
| i::is -> aux i is 0 [] xs
let range ?(step=1) start ~len =
let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in
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)
let range_until ?step start stop =
let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in
match step with
| None -> if stop <= start
then aux (fun i -> i > start) (1) [] (let len = (start - stop) in start - len + 1)
else aux (fun i -> i < start) (-1) [] (let len = (stop - start) in start + len - 1)
| 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)
| 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)
| _ -> invalid_arg "range_until"
let unique ?cmp ?(eq=(=)) xs =
let rec aux_mem eq x = function [] -> false | y::ys -> eq y x || aux_mem eq x ys in
let rec aux_all eq ys = function
| [] -> rev1 [] ys
| x::xs -> aux_all eq (if aux_mem eq x ys then ys else x::ys) xs in
let rec aux_sorted cmp ys y = function
| [] -> rev1 [y] ys
| x::xs -> if cmp y x = 0 then aux_sorted cmp ys y xs else aux_sorted cmp (y::ys) x xs in
match xs,cmp with
| [],_ | [_],_ -> xs
| x::xs, None -> aux_all eq [x] xs
| x::xs, Some cmp -> aux_sorted cmp [] x xs
let is_unique ?cmp ?(eq=(=)) xs =
let rec aux_mem eq sought = function [] -> false | x::xs -> eq x sought || aux_mem eq sought xs in
let rec aux_all eq ys = function
| [] -> true
| x::xs -> not (aux_mem eq x ys) && aux_all eq (x::ys) xs in
let rec aux_sorted cmp y = function
| [] -> true
| x::xs -> cmp y x < 0 && aux_sorted cmp x xs in
match xs,cmp with
| [],_ | [_],_ -> true
| x::xs, None -> aux_all eq [x] xs
| x::xs, Some cmp -> aux_sorted cmp x xs
let rec transpose = function
| [] -> []
| []::xss -> transpose xss
| (x::xs)::xss -> (x :: map head xss) :: transpose (xs :: map tail xss)
let sublists ?len ?many xs =
let rec aux_all = function [] -> [] | (x::xs) -> [x]::fold_left (fun yss ys -> (x::ys)::ys::yss) [] (aux_all xs) in
let rec aux_fixed k = function
| _ when k = 0 -> [[]]
| [] -> [] (* happens if k > length xs *)
| x::xs -> map (cons x) (aux_fixed (k-1) xs) ~onto:(aux_fixed k xs) in
let rec aux_replacing k = function
| _ when k = 0 -> [[]]
| [] -> [] (* will only happen if xs was [] to start with *)
| x::xs as orig -> map (cons x) (aux_replacing (k-1) orig) ~onto:(aux_replacing k xs) in
match len,many with
| None,None -> []::aux_all xs
| Some k,None -> if k < 0 then invalid_arg "sublists ~len" else aux_fixed k xs
| Some k,Some _ -> if k < 0 then invalid_arg "sublists ~len" else aux_replacing k xs
| None,Some _ -> invalid_arg "sublists ~many requires ~len"
let rec permutations ?len ?many xs =
let rec interleave' x xs f r = function
| [] -> xs, r
| y::ys -> let us,zs = interleave' x xs (fun ys -> f(y::ys)) r ys in y::us, f (x::y::us)::zs in
let interleave x xs r ys = let _,zs = interleave' x xs ident r ys in zs in
let rec aux ys = function
| [] -> []
| x::xs -> fold_left (interleave x xs) (aux (x::ys) xs) (permutations ys) in
let prod yss xs = catmap (fun x -> map (cons x) yss) xs in
match len,many with
| None,None -> xs::aux [] xs
| Some k,None -> if k < 0 then invalid_arg "permutations ~len" else catmap permutations (sublists ~len:k xs)
| Some k,Some _ -> if k < 0 then invalid_arg "permuations ~len" else if k = 0 then [] else fold_left prod [[]] (make k xs)
| None, Some _ -> invalid_arg "permutations ~many requires ~len"
let is_sublist ?(eq=(=)) xs ys =
let rec aux eq ys xs = match ys,xs with
| _,[] -> true
| [],_::_ -> false
| y::ys',x::xs' -> if eq y x then aux eq ys' xs' else aux eq ys' xs in
aux eq ys xs
let is_subset ?cmp ?(eq=(=)) ?many xs ys =
let rec aux_sorted uniq cmp ys xs = match ys,xs with
| _,[] -> true
| [],_::_ -> false
| 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
match cmp,many with
| None,Some _ -> for_all (fun x -> mem ~eq x ys) xs
| Some cmp,None -> aux_sorted true cmp ys xs
| Some cmp,Some _ -> aux_sorted false cmp ys xs
| None,None -> invalid_arg "is_subset requires ~cmp and/or ~many"
let is_eqset ?(eq=(=)) xs ys =
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
try (match fold_left (fun ys x -> let _,ys = aux eq x [] ys in ys) ys xs with [] -> true | _ -> false)
with Not_found -> false
let rec lexcmp ?(cmp=compare) xs ys = match xs, ys with
| [],[] -> 0
| _,[] -> 1
| [],_ -> -1
| 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
let diff ?cmp ?(eq=(=)) ?many xs ys = fold_left (fun xs y -> delete ?cmp ~eq ?many y xs) xs ys
(*
let union ?cmp ?(eq=(=)) xs ys = append xs (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs)
*)
let union ?cmp ?(eq=(=)) ys xs = append (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs) xs
let intersect ?cmp ?(eq=(=)) xs ys =
let rec aux_all eq ws zs xs ys = match xs,ys with
| _,[] -> rev1 [] zs
| [],y::ys' -> aux_all eq [] zs (* don't need to reverse ws *) ws ys'
| 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
let rec aux_sorted cmp zs xs ys = match xs,ys with
| [],_ | _,[] -> rev1 [] zs
| 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
match cmp with
| None -> aux_all eq [] [] xs ys
| Some cmp -> aux_sorted cmp [] xs ys
let merge ?(cmp=compare) xs ys =
let rec aux cmp zs xs ys = match xs, ys with
| [],ys -> rev1 ys zs
| xs,[] -> rev1 xs zs
| x'::xs',y'::ys' -> if cmp x' y' <= 0 then aux cmp (x'::zs) xs' ys else aux cmp (y'::zs) xs ys' in
aux cmp [] xs ys
(*
"Natural" or "adaptive" bottom-up merge sort, inspired by http://www.drmaciver.com/tag/timsort/.
Optimized to exploit existing runs of ascending/descending elements, to consume at most O(log n) levels of its working stack,
and to be mostly tail-recursive, while minimizing how often sorted and merged runs need to be reversed.
Sort is stable, and has O(n log n) avg and worst-case behavior.
(Compare to naive mergesort on random data, also to C-implemented qsort, which isn't stable?)
Will delete (later occurrences of) any duplicates, unless invoked with ~many.
Copyright (c) 2012, 2015 by Dubiousjim .
See license at https://github.com/dubiousjim/unspoiled/blob/master/LICENSE
*)
let sort ?(cmp=compare) ?many ?rev xs =
let rec merge uniq cmp wasc yy zz ws wn =
assert (wasc <> 0); match yy,zz with
| us,[] | [],us -> rev1 ws us, wn, -wasc
| y::ys,z::zs -> let res = cmp y z in
if uniq && res = 0 then (assert (wn<>1); merge uniq cmp wasc ys zz ws (if wn = 0 then 0 else wn - 1))
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
let rec merge1 uniq cmp ys yn yasc zss = match zss with
| [] -> None
| (z::zs' as zs,zn,zasc)::zss as orig -> (match ys with
| [] -> assert false
| y::ys' ->
(* yn = 0 forces collapse of stack *)
if yn > 0 && yn*2 <= zn then None
else let wn = if yn > 0 then yn + zn else 0 in
if yasc = 0 then (assert (yn <= 1); merge2 uniq cmp zss (merge uniq cmp zasc ys zs [] wn))
else let res = cmp y z in
let () = assert (yn <> 1) in
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)
else if yasc < 0 && zasc > 0 && res >= 0 then merge2 uniq cmp zss (rev1 zs ys, wn, 1)
else if yasc > 0 && zasc < 0 && res < 0 then merge2 uniq cmp zss (rev1 ys zs, wn, 1)
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
merge2 uniq cmp zss (merge uniq cmp wasc ys zs [] wn))
| _ -> assert false
and merge2 uniq cmp zss (ws,wn,wasc) =
let more = merge1 uniq cmp ws wn wasc zss in
match more with None -> Some ((ws,wn,wasc)::zss) | _ -> more in
(* 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 *)
let rec step uniq cmp xs y ys yn yasc zss =
match xs with
| (x::xs) ->
let res = cmp x y in
if uniq && res = 0 then step uniq cmp xs y ys yn yasc zss
else if yn = 1 then step uniq cmp xs x (y::ys) 2 (if res < 0 then -1 else 1) zss
else (assert (yasc <> 0); if (yasc < 0) = (res < 0) then step uniq cmp xs x (y::ys) (yn+1) yasc zss
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))
| [] -> (* finished stepping through original list, use yn = 0 to force merge1 until completion *)
(match merge1 uniq cmp (y::ys) 0 yasc zss with
| Some [(ys,0,yasc)] -> if yasc > 0 then rev1 [] ys else ys
| None -> if yasc > 0 then rev1 [y] ys else y::ys
| _ -> assert false) in
match many,rev,xs with
| _,_,[] | _,_,[_] -> xs
| None,None,x::xs -> step true cmp xs x [] 1 0 []
| Some _,None,x::xs -> step false cmp xs x [] 1 0 []
| None,Some _,x::xs -> step true (fun x y -> -cmp x y) xs x [] 1 0 []
| Some _,Some _,x::xs -> step false (fun x y -> -cmp x y) xs x [] 1 0 []
let is_sorted ?(cmp=compare) ?many ?rev xs =
let rec aux cmp thresh y = function
| [] -> true
| x::xs -> cmp y x < thresh && aux cmp thresh x xs in
match rev,xs with
| _,[] | _,[_] -> true
| None,x::xs -> aux cmp (match many with None -> 0 | Some _ -> 1) x xs
| Some _,x::xs -> aux (fun x y -> -cmp x y) (match many with None -> 0 | Some _ -> 1) x xs
let string_of_list ?(brackets=true) ?(sep=";") f xs =
let rec aux sep' = function [] -> if brackets then "]" else "" | x::xs -> sep' ^ f x ^ aux sep xs in
(if brackets then "[" else "") ^ aux "" xs
let histogram ?(eq=(=)) xs = fold_left (fun h x -> modify_assoc x (fun _ n -> n+1) ~missing:(fun _ -> 1) ~eq h) [] xs
let pairwise ?missing xs =
let rec aux missing x = function
| [] -> (match missing with None -> [] | Some y -> [(x,y)])
| y::ys -> (x,y)::aux missing y ys in
match xs with
| [] -> []
| x::xs -> aux missing x xs
let rec round_robin xss =
let rec aux ws ys = function
| [] -> (match ys with [] -> rev1 [] ws | _ -> aux ws [] (rev1 [] ys))
| []::xss -> aux ws ys xss
| (x::xs)::xss -> aux (x::ws) (xs::ys) xss in
match xss with
| [] -> raise Short_list
| []::xss -> round_robin xss
| xss -> aux [] [] xss
let rec chunk n xs = match split n xs with
| ys,[] -> [ys]
| ys,zs -> ys::chunk n zs
let rec chunk' n xs = match split' n xs with
| ys,[] -> [ys]
| ys,zs -> ys::chunk' n zs
let chunk_int n xs =
let rec aux n = function
| _ when n = 0 -> [[]]
| [] -> []
| x::xs as orig -> if x > n then aux n xs else map ~onto:(aux n xs) (cons x) (aux (n-x) orig) in
let xs = sort ~many xs in
match sort xs with x::_ as xs when x > 0 && n > 0 -> aux n (rev1 [] xs) | _ -> invalid_arg "chunk_int"
let chunk_range sizes =
let rec combs2 k = function
| xs when k = 0 -> [([],xs)]
| [] -> []
| 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
let rec p xs = function
| [] -> [[]]
| k::ks -> catmap (fun (cs,zs) -> map (cons cs) (p zs ks)) (combs2 k xs) in
if exists (fun x -> x<0) sizes then invalid_arg "chunk_range" else p (range_until 0 (sum sizes)) sizes
end (* List *)
let short = List.short
let many = List.many
exception Short_list = List.Short_list
let is_null = List.is_null
let length = List.length
let cons = List.cons
let snoc = List.snoc
let singleton = List.singleton
let head = List.head
let opthead = List.opthead
let tail = List.tail
let tail' = List.tail'
let uncons = List.uncons
let append = List.append
let concat = List.concat
let rev = List.rev
let zip = List.zip
let unzip = List.unzip
let iter = List.iter
let iteri = List.iteri
let iter2 = List.iter2
let fold_left = List.fold_left
let fold_left1 = List.fold_left1
let fold_left2 = List.fold_left2
let fold_right = List.fold_right
let fold_right1 = List.fold_right1
let fold_right2 = List.fold_right2
let for_all = List.for_all
let exists = List.exists
let for_all2 = List.for_all2
let exists2 = List.exists2
let sum = List.sum
let product = List.product
let take = List.take
let take' = List.take'
let drop = List.drop
let drop' = List.drop'
let split = List.split
let split' = List.split'
let nth = List.nth
(*
count
make
last
init
init'
mem
map
map2
unmap2
mapi
optmap
optmapi
catmap
catmapi
maximum
minimum
maxby
minby
modify
optmodify
catmodify
take_while
drop_while
split_while
find
optfind
findx
index
remove
delete
pick
pickx
filter
filterx
indices
partition
partitionx
assoc
mem_assoc
modify_assoc
optmodify_assoc
remove_assoc
memq
indexq
deleteq
indicesq
assq
mem_assq
modify_assq
optmodify_assq
remove_assq
rotate
unfold
mapz
group
cross
insert
select
range
range_until
unique
is_unique
transpose
permutations
sublists
is_sublist
is_subset
is_eqset
lexcmp
diff
union
intersect
merge
sort
is_sorted
string_of_list
histogram
pairwise
round_robin
chunk
chunk'
chunk_int
chunk_range
*)
let factorial n = let rec aux m = function 0 -> m | 1 -> m | n -> aux (n*m) (n-1) in aux 1 n
(* good to around n = 28; naive version overflows after n = 20 *)
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)
module Random : sig
val init : ?seed:int -> unit -> unit
val bool : unit -> bool
(* start <= result < stop *)
val between : int -> int -> int
val nth : 'a list -> 'a
val pick : 'a list -> 'a * 'a list
(* k dice rolls are `permutation ~len:k ~many [1..6]` *)
val permutation : ?len:int -> ?many:'b -> 'a list -> 'a list
(* choose k elements from xs, in stable order, ~many with replacment *)
val sublist : len:int -> ?many:'b -> 'a list -> 'a list
end = struct
let init ?seed () =
match seed with
| None -> Std.Random.self_init()
| Some n -> Std.Random.init n
let bool = Std.Random.bool
let between start stop = Std.Random.int (stop-start) + start
let nth xs = match List.length xs with
| 0 -> invalid_arg "Random.nth"
| n -> List.nth xs (between 0 n)
let pick xs =
let rec aux n ws = function
| x::xs -> if n = 0 then x, List.rev ~onto:xs ws else aux (n-1) (x::ws) xs
| [] -> assert false in
match List.length xs with
| 0 -> invalid_arg "Random.pick"
| n -> aux (between 0 n) [] xs
let permutation ?len ?many xs =
(* a[j],a[n] = x,a[j] *)
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
(* return,a[j] = a[j],a[n] *)
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
let rec aux_all a n = function
(* Based on https://en.wikipedia.org/wiki/Fisher-Yates_shuffle#The_.22inside-out.22_algorithm
Initialize empty array to shuffled copy of xs *)
| [] -> Array.to_list a
| x::xs -> let j = between 0 (n+1) in (array_push a j n x; aux_all a (n+1) xs) in
let rec aux_fixed k n a ws = function
| 0 -> ws
| 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
match len,many,xs with
| None,_,[] -> []
| Some k,_,[] -> if k = 0 then [] else invalid_arg "Random.permutation"
| None,None,x::_ -> aux_all (Array.make (List.length xs) x) 0 xs
| Some k,None,_ -> if k < 0 then invalid_arg "Random.permutation" else aux_fixed k (List.length xs) (Array.of_list xs) [] k
| Some k,Some _,_ -> if k < 0 then invalid_arg "Random.permutation" else iterate k (fun ys -> nth xs::ys) []
| None,Some _,_ -> invalid_arg "Random.permutation ~many requires ~len"
let sublist ~len:k ?many xs =
let rec aux_fixed ws n k = function
| _ when k = 0 -> List.rev ws
| (x::xs) ->
(* 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.
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. *)
if between 0 n < k then aux_fixed (x::ws) (n-1) (k-1) xs else aux_fixed ws (n-1) k xs
| _ -> assert false in
let rec aux_replacing k top ws = function
| _ when k = 0 -> List.rev ws
| [] -> [] (* will only happen when xs was [] to start with *)
| x::xs as orig ->
(* 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.
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). *)
if between 0 (k+top) < k then aux_replacing (k-1) top (x::ws) orig else aux_replacing k (top-1) ws xs in
let n = List.length xs in
if k < 0 || k > n then invalid_arg "Random.sublist"
else match many with
| None -> aux_fixed [] n k xs
| Some _ -> aux_replacing k (n-1) [] xs
end (* Random *)
(* #load "Str.cma";; *)
module String : sig
type t = string
val compare : 'a -> 'a -> int
val length : string -> int
val take : int -> ?rev:'a -> string -> string
val drop : int -> string -> string
val sub : string -> int -> len:int -> string
val is_prefix : string -> string -> bool
val is_suffix : string -> string -> bool
val is_infix : string -> string -> bool
val find : string -> ?rev:'a -> ?from:int -> string -> int
val nth : string -> int -> char
val make : int -> char -> string
val mem : char -> ?rev:'a -> ?from:int -> string -> bool
val index : ?rev:'a -> ?from:int -> char -> string -> int
val upper : string -> string
val lower : string -> string
val int_of_char : char -> int
val char_of_int : int -> char
(* trim only removes up to 1 leading/trailing occurrence of pat *)
val trim : string -> string
type pat = string
val split : string -> ?n:int -> ?trim:'a -> pat -> string list
val join : sep:string -> string list -> string
val lines : ?trim:'a -> string -> string list (* as in Haskell, gobbles up to 1 \n per line *)
val words : string -> string list
val unlines : string list -> string (* as in Haskell, does add a trailing \n *)
val unwords : string list -> string (* as in Haskell, no trailing space *)
end = struct
type t = string
let compare = compare
let length = Std.String.length
let take n ?rev s = match rev with
| None -> Str.string_before s n
| Some _ -> Str.last_chars s n
let drop n s = Str.string_after s n
let sub s start ~len = Std.String.sub s start len
let is_prefix (sought : string) s = let n = length sought in length s >= n && take n s = sought
let is_suffix (sought : string) s = let n = length sought in length s >= n && take n ~rev:() s = sought
let is_infix (sought : string) s = length sought <= length s && try Str.(search_forward (regexp_string sought) s 0) >= 0 with Not_found -> false
let find (sought : string) ?rev ?from s = match rev,from with
| None,None -> Str.(search_forward (regexp_string sought) s 0)
| None,Some n -> Str.(search_forward (regexp_string sought) s n)
| Some _,Some n -> Str.(search_backward (regexp_string sought) s n)
| 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)
let nth s n = Std.String.get s n
let make n c = Std.String.make n c
let mem (sought : char) ?rev ?from s = match rev,from with
| None,None -> Std.String.contains s sought
| None,Some n -> Std.String.contains_from s n sought
| Some _,Some n -> Std.String.rcontains_from s n sought
| Some _,None -> invalid_arg "String.mem ~rev requires ~from"
let index ?rev ?from (sought : char) s = match rev,from with
| None,None -> Std.String.index s sought
| Some _,None -> Std.String.rindex s sought
| None,Some n -> Std.String.index_from s n sought
| Some _,Some n -> Std.String.rindex_from s n sought
let upper s = Std.String.uppercase s
let lower s = Std.String.lowercase s
let int_of_char (c : char) = Std.Char.code c
let char_of_int (n : int) = Std.Char.chr n
let trim s = Std.String.trim s
type pat = string
let split s ?n ?trim pat = match n,trim with
| None,Some _ -> Str.(split (regexp pat) s)
| Some n,Some _ -> Str.(bounded_split (regexp pat) s n)
| None,None -> Str.(split_delim (regexp pat) s)
| Some n,None -> Str.(bounded_split_delim (regexp pat) s n)
let join ~sep ss = Std.String.concat sep ss
let lines ?trim s = split ("\n"^s) ~trim "\n"
let words s = split s ~trim "[ \t\n]+"
let unlines ss = join "\n" ss ^ "\n"
let unwords ss = join " " ss
end (* String *)
end (* Juli8 *)
open Juli8
#use "monad.ml"