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