-(* 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 <dubiousjim@gmail.com>.
- 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"