--- /dev/null
+(* 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
--- /dev/null
+(* 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
+