From 59a91510110916c1467d62f70828c53fb7c96bc3 Mon Sep 17 00:00:00 2001
From: Jim <jim.pryor@nyu.edu>
Date: Wed, 1 Apr 2015 14:28:41 -0400
Subject: [PATCH] add OCaml main+list+monad libraries

---
 code/juli8.ml | 1521 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 code/monad.ml | 1134 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 2655 insertions(+)
 create mode 100644 code/juli8.ml
 create mode 100644 code/monad.ml

diff --git a/code/juli8.ml b/code/juli8.ml
new file mode 100644
index 00000000..f8f9cb3c
--- /dev/null
+++ b/code/juli8.ml
@@ -0,0 +1,1521 @@
+(* 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
diff --git a/code/monad.ml b/code/monad.ml
new file mode 100644
index 00000000..79dbf4f6
--- /dev/null
+++ b/code/monad.ml
@@ -0,0 +1,1134 @@
+(* This version from 1 April 2015 *)
+
+module Monad = struct
+
+  module type MAPPABLE = sig
+    type 'a t
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    (* mapconst is definable as map % const. For example mapconst 4 [1,2,3] == [4,4,4]. Haskell calls mapconst <$ in Data.Functor and Control.Applicative. They also use $> for flip mapconst, and Control.Monad.void for mapconst (). *)
+  end
+
+  module type APPLICATIVE = sig
+    include MAPPABLE
+    val mid : 'a -> 'a t
+    val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+    val mapply : ('a -> 'b) t -> 'a t -> 'b t
+    val (>>) : 'a t -> 'b t -> 'b t
+    val (<<) : 'a t -> 'b t -> 'a t
+  end
+
+  module type MONAD = sig
+    include APPLICATIVE
+    type 'a result
+    val run : 'a t -> 'a result
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
+    val (<=<) : ('b -> 'c t) -> ('a -> 'b t) -> ('a -> 'c t)
+    val join : 'a t t -> 'a t
+    val ignore : 'a t -> unit t
+    val seq : 'a t list -> 'a list t
+    val seq_ignore : unit t list -> unit t
+    val do_when : bool -> unit t -> unit t
+    val do_unless : bool -> unit t -> unit t
+  end
+
+  module type MONADT = sig
+    include MONAD
+    type 'a ut
+    val hoist : 'a ut -> 'a t
+  end
+
+  module type MONADZERO = sig
+    include MONAD
+    (* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *)
+    val mzero : 'a t
+    val guard : bool -> unit t
+  end
+
+  module type MONADZEROT = sig
+    include MONADZERO
+    type 'a ut
+    val hoist : 'a ut -> 'a t
+  end
+
+  module type MAPPABLE2 = sig
+    type ('a,'d) t
+    val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
+  end
+
+  module type APPLICATIVE2 = sig
+    include MAPPABLE2
+    val mid : 'a -> ('a,'d) t
+    val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
+    val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
+    val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t
+    val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t
+  end
+
+  module type MONAD2 = sig
+    include APPLICATIVE2
+    type ('a,'d) result
+    val run : ('a,'d) t -> ('a,'d) result
+    val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+    val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
+    val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t)
+    val join : (('a,'d) t,'d) t -> ('a,'d) t
+    val ignore : ('a,'d) t -> (unit,'d) t
+    val seq : ('a,'d) t list -> ('a list,'d) t
+    val seq_ignore : (unit,'d) t list -> (unit,'d) t
+    val do_when : bool -> (unit,'d) t -> (unit,'d) t
+    val do_unless : bool -> (unit,'d) t -> (unit,'d) t
+  end
+
+  module type MONAD2T = sig
+    include MONAD2
+    type ('a,'d) ut
+    val hoist : ('a,'d) ut -> ('a,'d) t
+  end
+
+  module type MONADZERO2 = sig
+    include MONAD2
+    val mzero : ('a,'d) t
+    val guard : bool -> (unit,'d) t
+  end
+
+  module type MONADZERO2T = sig
+    include MONADZERO2
+    type ('a,'d) ut
+    val hoist : ('a,'d) ut -> ('a,'d) t
+  end
+
+  module Make = struct
+
+    module type MAP2 = sig
+      type 'a t
+      val mid : 'a -> 'a t
+      val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type MAPPLY = sig
+      type 'a t
+      val mid : 'a -> 'a t
+      val mapply : ('a -> 'b) t -> 'a t -> 'b t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+    end
+
+    module type BIND = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type COMP = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type JOIN = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val join : 'a t t -> 'a t
+      val map : ('a -> 'b) -> 'a t -> 'b t
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type TRANS = sig
+      module U : MONAD
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      (* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *)
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    end
+
+    module type TRANSUZ = sig
+      module U : MONADZERO
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    end
+
+    module type TRANSZ = sig
+      module U : MONAD
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val mzero : 'a t
+    end
+
+    module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let (>>=) = B.(>>=)
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
+      let mapply = match B.map2 with
+      | `Custom map2 -> fun eta -> map2 ident eta
+      | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
+      let (>>) xx yy = xx >>= fun _ -> yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let map2 = B.map2
+      let mapply = match B.mapply with
+      | `Custom mapply -> mapply
+      | `Generate -> fun eta -> map2 ident eta
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let mapply = B.mapply
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> mapply (map f xx) yy
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let (>>=) = B.(>>=)
+      include ApplicativeFromBind(B)
+      type 'a result = 'a B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      (* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *)
+      (* 
+         foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z  -- foldr but evaluating from left?
+         foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work
+         -- with foldr, evaluates left->right; with foldl the reverse
+         seq xxs =
+           let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return
+           reverse <$> foldr (f $ flip (:)) return xxs []
+           -- or simply: foldr (f snoc) return xxs []
+      *)
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let (>=>) = B.(>=>)
+      let (<=<) k j = j >=> k
+      let (>>=) xx k = (ident >=> k) xx
+      include ApplicativeFromBind(struct include B let (>>=) = (>>=) end)
+      type 'a result = 'a B.result
+      let run = B.run
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let join = B.join
+      let (>>=) xx k = join (B.map k xx)
+      include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
+      type 'a result = 'a B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      include MonadFromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+    end
+
+    module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
+      include MonadFromBind(struct
+        include B
+        let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let guard res = if res then mid () else mzero
+    end
+
+    module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      include MonadFromBind(struct
+        include B
+        let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = B.mzero
+      let guard res = if res then mid () else mzero
+    end
+
+    module type BIND2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type COMP2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type JOIN2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val join : (('a,'d) t,'d) t -> ('a,'d) t
+      val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type TRANS2 = sig
+      module U : MONAD2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+    end
+
+    module type TRANSUZ2 = sig
+      module U : MONADZERO2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+    end
+
+    module type TRANSZ2 = sig
+      module U : MONAD2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+      val mzero : ('a,'d) t
+    end
+
+    module type MAP22 = sig
+      type ('a,'d) t
+      val mid : 'a -> ('a,'d) t
+      val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type MAPPLY2 = sig
+      type ('a,'d) t
+      val mid : 'a -> ('a,'d) t
+      val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+    end
+
+    module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let (>>=) = B.(>>=)
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
+      let mapply = match B.map2 with
+      | `Custom map2 -> fun eta -> map2 ident eta
+      | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
+      let (>>) xx yy = xx >>= fun _ -> yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let map2 = B.map2
+      let mapply = match B.mapply with
+      | `Custom mapply -> mapply
+      | `Generate -> fun eta -> map2 ident eta
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let mapply = B.mapply
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> mapply (map f xx) yy
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let (>>=) = B.(>>=)
+      include Applicative2FromBind(B)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let (>=>) = B.(>=>)
+      let (<=<) k j = j >=> k
+      let (>>=) xx k = (ident >=> k) xx
+      include Applicative2FromBind(struct include B let (>>=) = (>>=) end)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let join = B.join
+      let (>>=) xx k = join (B.map k xx)
+      include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromT(B : TRANS2) : MONAD2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+    end
+
+    module Monad2FromTUZ(B : TRANSUZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
+      let guard res = if res then mid () else mzero
+    end
+
+    module Monad2FromTZ(B : TRANSZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = B.mzero
+      let guard res = if res then mid () else mzero
+    end
+
+  end (* Make *)
+
+
+
+  module Option = struct
+    include Juli8.Option
+    module type EXTRA = sig
+      type 'a t
+      val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
+    end
+    module type EXTRA2 = sig
+      type ('a,'d) t
+      val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
+    end
+    module M : sig
+      include MONADZERO with type 'a result = 'a option
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a option
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
+        let mid = some
+        (* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *)
+        let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
+      end)
+      let mzero = None
+      let guard res : unit t = if res then Some () else None
+      let test p xx = if p xx then xx else None
+    end (* Option.M *)
+    module M2 : sig
+      include MONADZERO2 with type ('a,'d) result = 'a option
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+    end = struct
+      include Make.Monad2FromBind(struct
+        type ('a,'d) t = 'a option
+        type ('a,'d) result = ('a,'d) t let run xx = xx
+        let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
+        let mid = some
+        let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
+      end)
+      let mzero = None
+      let guard res : (unit,'d) t = if res then Some () else None
+      let test p xx = if p xx then xx else None
+    end (* Option.M2 *)
+    module T(U : MONAD) : sig
+      include MONADZEROT with type 'a result = 'a option U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val test : ('a option U.t -> bool) -> 'a t -> 'a t
+    end = struct
+      include Make.MonadFromTZ(struct
+        module U = U
+        type 'a t = 'a option U.t
+        type 'a result = 'a option U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (Some u)) 
+        let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
+        let mzero = Obj.magic U.(mid None)
+      end)
+      let test p xx = if p xx then xx else U.mid None
+    end (* Option.T *)
+    module T2(U : MONAD2) : sig
+      include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+      val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
+    end = struct
+      include Make.Monad2FromTZ(struct
+        module U = U
+        type ('a,'d) t = ('a option,'d) U.t
+        type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (Some u)) 
+        let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
+        let mzero = Obj.magic U.(mid None)
+      end)
+      let test p xx = if p xx then xx else U.mid None
+    end (* Option.T2 *)
+  end (* Option *)
+
+  module List = struct
+    include Juli8.List
+    module type EXTRA = sig
+      type 'a t
+      val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+      val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
+      val test : ('a list (* U.t *) -> bool) -> 'a t -> 'a t
+    end
+    module type EXTRA2 = sig
+      type ('a,'d) t
+      val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
+      val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
+      val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
+    end
+    module M : sig
+      include MONADZERO with type 'a result = 'a list
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a list
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
+        let mid = singleton
+        let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
+      end)
+      let mzero = []
+      let guard res : unit t = if res then [()] else []
+      (* (++) has tighter precedence than (>>=) *)
+      let (++) = append
+      let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
+      let test p xx = if p xx then xx else []
+    end (* List.M *)
+    module M2 : sig
+      include MONADZERO2 with type ('a,'d) result = 'a list
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+    end = struct
+      include Make.Monad2FromBind(struct
+        type ('a,'d) t = 'a list
+        type ('a,'d) result = ('a,'d) t let run xx = xx
+        let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
+        let mid = singleton
+        let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
+      end)
+      let mzero = []
+      let guard res : (unit,'d) t = if res then [()] else []
+      let (++) = append
+      let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
+      let test p xx = if p xx then xx else []
+    end (* List.M2 *)
+    module T(U : MONAD) : sig
+      include MONADZEROT with type 'a result = 'a list U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val test : ('a list U.t -> bool) -> 'a t -> 'a t
+      (*
+          Monadically seq k over box<a>.
+          OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+          ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+          TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+      *)
+      val distribute : ('a -> 'b U.t) -> 'a list -> 'b t
+    end = struct
+      let distribute k xs = U.seq (List.map k xs)
+      include Make.MonadFromTZ(struct
+        module U = U
+        type 'a t = 'a list U.t
+        type 'a result = 'a list U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid [u]) 
+        let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
+        let mzero = Obj.magic U.(mid [])
+      end)
+      let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
+      let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
+      let test p xx = if p xx then xx else U.mid []
+    end (* List.T *)
+    module T2(U : MONAD2) : sig
+      include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+      val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
+      val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t
+    end = struct
+      let distribute k xs = U.seq (List.map k xs)
+      include Make.Monad2FromTZ(struct
+        module U = U
+        type ('a,'d) t = ('a list,'d) U.t
+        type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid [u]) 
+        let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
+        let mzero = Obj.magic U.(mid [])
+      end)
+      let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
+      let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
+      let test p xx = if p xx then xx else U.mid []
+    end (* List.T2 *)
+  end (* List *)
+
+
+  (* LTree, unit centers, has natural ++ *)
+  (* ITree, unit leaves, has natural mzero *)
+
+  module LTree = struct
+    type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
+    let branch x y = Branch(x,y)
+    let leaf x = Leaf x
+    let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
+      let rec aux = function
+      | Leaf x -> k x
+      | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
+      aux xt
+    let map (f : 'a -> 'b) (xt : 'a tree) =
+      let rec aux = function
+      | Leaf x -> Leaf (f x)
+      | Branch(l, r) -> Branch(aux l, aux r) in
+      aux xt
+    module type EXTRA = sig
+      type 'a t
+      val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a tree
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a tree
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom map let map2 = `Generate let mapply = `Generate
+        let mid = leaf
+        let (>>=) xx k = traverse branch k xx
+      end)
+      let (++) xx yy = Branch(xx, yy)
+    end (* Tree.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      (*
+          Monadically seq k over box<a>.
+          OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+          ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+          TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+      *)
+      val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
+    end = struct
+      let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) 
+      let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = 'a tree U.t
+        type 'a result = 'a tree U.result let run xx = U.run xx
+        let hoist = hoist
+        let join xtt = traverse branch ident xtt
+        let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
+      end)
+      let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
+    end (* Tree.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
+    end = struct
+      let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) 
+      let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = 'a tree U.t
+        type 'a result = 'a tree U.result let run xx = U.run xx
+        let hoist = hoist
+        let join xtt = traverse branch ident xtt
+        let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
+      end)
+      let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
+    end (* Tree.Z *)
+  end (* Tree *)
+
+
+  module Identity = struct
+    module M : sig
+      include MONAD with type 'a result = 'a
+    end = struct
+      include Make.MonadFromComp(struct
+        type 'a t = 'a
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom (fun f x -> f x) let map2 = `Custom (fun f x y -> f x y) let mapply = `Custom (fun f x -> f x)
+        let mid = ident
+        let (>=>) j k = fun x -> k (j x)
+      end)
+    end
+  end
+
+  (* must be parameterized on `struct type env = ... end` *)
+  module Reader(E : sig type env end) = struct
+    type env = E.env
+    module type EXTRA = sig
+      type 'a t
+      val ask : env t
+      val asks : (env -> 'a) -> 'a t
+      val shift : (env -> env) -> 'a t -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = env -> 'a
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = env -> 'a
+        type 'a result = 'a t let run xx = fun e -> xx e
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun e -> x
+        let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e
+      end)
+      let ask = fun e -> e
+      let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = env -> 'a U.t
+        type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
+        let hoist uu = fun e -> uu
+        let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
+      end)
+      let ask = U.mid
+      let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = env -> 'a U.t
+        type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
+        let hoist uu = fun e -> uu
+        let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
+      end)
+      let ask = U.mid
+      let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.Z *)
+  end (* Reader *)
+
+  (* must be parameterized on `struct type store = ... end` *)
+  module State(S : sig type store end) = struct
+    type store = S.store
+    module type EXTRA = sig
+      type 'a t
+      val get : store t
+      val gets : (store -> 'a) -> 'a t
+      val put : store -> unit t
+      val modify : (store -> store) -> unit t
+    end
+    module M : sig
+      include MONAD with type 'a result = store -> 'a * store
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = store -> 'a * store
+        type 'a result = 'a t let run xx = fun s -> xx s
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun s -> x, s
+        let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
+      end)
+      let get = fun s -> s,s
+      (* `gets viewer` is `map viewer get` *)
+      let gets viewer = fun s -> viewer s, s (* may fail with Not_found *)
+      let put s = fun _ -> (), s
+      let modify modifier = fun s -> (), modifier s
+    end (* State.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = store -> ('a * store) U.t
+        type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let get = fun s -> U.mid (s,s)
+      let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *)
+      let put s = fun _ -> U.mid ((), s)
+      let modify modifier = fun s -> U.mid ((), modifier s)
+    end (* State.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = store -> ('a * store) U.t
+        type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let get = fun s -> U.mid (s,s)
+      let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s
+      let put s = fun _ -> U.mid ((), s)
+      let modify modifier = fun s -> U.mid ((), modifier s)
+    end (* State.Z *)
+  end (* State *)
+
+  (* State with a different interface; must be parameterized on `struct type value = ... end` *)
+  module Ref(V : sig type value end) = struct
+    type ref = int
+    type value = V.value
+    module D = Map.Make(struct type t = ref let compare = compare end)
+    type dict = { next : ref; tree : value D.t }
+    let empty = { next = 0; tree = D.empty }
+    let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
+    let read (k : ref) d = D.find k d.tree
+    let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
+    module type EXTRA = sig
+      type 'a t
+      val newref : value -> ref t
+      val deref : ref -> value t
+      val change : ref -> value -> unit t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = dict -> 'a * dict
+        type 'a result = 'a let run xx = fst (xx empty)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun s -> x, s
+        let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
+      end)
+      let newref v = fun s -> alloc v s
+      let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
+      let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
+    end (* Ref.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = dict -> ('a * dict) U.t
+        type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let newref v = fun s -> U.mid (alloc v s)
+      let deref k = fun s -> U.mid (read k s, s)
+      let change k v = fun s -> U.mid ((), write k v s)
+    end (* Ref.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = dict -> ('a * dict) U.t
+        type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let newref v = fun s -> U.mid (alloc v s)
+      let deref k = fun s -> U.mid (read k s, s)
+      let change k v = fun s -> U.mid ((), write k v s)
+    end (* Ref.Z *)
+  end (* Ref *)
+
+  (* must be parameterized on `struct type log = ... end` *)
+  module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
+    type log = W.log
+    module type EXTRA = sig
+      type 'a t
+      val listen : 'a t -> ('a * log) t
+      val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
+      val tell : log -> unit t
+      (* val pass : ('a * (log -> log)) t -> 'a t *)
+      val censor : (log -> log) -> 'a t -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a * log
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a * log
+        type 'a result = 'a t let run xx = xx
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = x, W.empty
+        let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w')
+      end)
+      let listen (x,w) = (x,w), w
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *)
+      let tell entries = (), entries (* add to log *)
+      let pass ((x,c),w) = (x, c w) (* usually use censor *)
+      let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
+    end (* Writer.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = ('a * log) U.t
+        type 'a result = ('a * log) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
+        let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
+      end)
+      let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
+      let tell entries = U.mid ((), entries)
+      let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
+      let censor c xx = pass (xx >>= fun x -> mid (x,c))
+    end (* Writer.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = ('a * log) U.t
+        type 'a result = ('a * log) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
+        let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
+      end)
+      let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
+      let tell entries = U.mid ((), entries)
+      let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
+      let censor c xx = pass (xx >>= fun x -> mid (x,c))
+    end (* Writer.Z *)
+  end (* Writer *)
+
+  (* must be parameterized on `struct type err = ... end` *)
+  module Error(E : sig type err exception Exc of err end) = struct
+    type err = E.err
+    type 'a error = Error of err | OK of 'a
+    module type EXTRA = sig
+      type 'a t
+      val throw : err -> 'a t
+      val catch : 'a t -> (err -> 'a t) -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a error
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a error
+        type 'a result = 'a t let run xx = xx
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = OK x
+        let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
+      end)
+      let throw e = Error e
+      let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
+    end (* Error.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = 'a error U.t
+        type 'a result = 'a U.result
+        let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
+        let hoist uu = U.(uu >>= fun u -> mid (OK u)) 
+        let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
+      end)
+      let throw e = U.mid (Error e)
+      let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
+    end (* Error.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = 'a error U.t
+        type 'a result = 'a U.result
+        (* we recover from error by using U's mzero; but this discards the error msg *)
+        let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu
+        let hoist uu = U.(uu >>= fun u -> mid (OK u)) 
+        let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
+      end)
+      let throw e = U.mid (Error e)
+      let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
+    end (* Error.Z *)
+  end (* Error *)
+
+  (* predefine some common instances *)
+
+  module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
+
+  module Writer2 = struct
+    include Writer(struct
+      type log = string list
+      let empty = []
+      let append s1 s2 = List.append s2 s1
+    end)
+    (* FIXME these aren't inside M *)
+    let tell_string s = M.tell [s]
+    let tell entries = M.tell (List.rev entries)
+    let run xx = let (x,w) = M.run xx in (x, List.rev w)
+  end
+
+  module Failure = Error(struct type err = string exception Exc = Failure end)
+
+end (* Monad *)
+
+module Option = Monad.Option
+module List = Monad.List
+
-- 
2.11.0