code/juli8.ml

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