From: Jim Date: Sat, 4 Apr 2015 23:24:47 +0000 (-0400) Subject: tweak reader2.ml, add Juli8.tgz X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=0b126d1ce50e3ae395ad6ed93c7c3f7040c050bc tweak reader2.ml, add Juli8.tgz --- diff --git a/code/Juli8-v1.2.tgz b/code/Juli8-v1.2.tgz new file mode 100644 index 00000000..c3c2f011 Binary files /dev/null and b/code/Juli8-v1.2.tgz differ diff --git a/code/juli8.ml b/code/juli8.ml deleted file mode 100644 index 821a09f3..00000000 --- a/code/juli8.ml +++ /dev/null @@ -1,1523 +0,0 @@ -(* 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 . - See license at https://github.com/dubiousjim/unspoiled/blob/master/LICENSE - *) - - let sort ?(cmp=compare) ?many ?rev xs = - let rec merge uniq cmp wasc yy zz ws wn = - assert (wasc <> 0); match yy,zz with - | us,[] | [],us -> rev1 ws us, wn, -wasc - | y::ys,z::zs -> let res = cmp y z in - if uniq && res = 0 then (assert (wn<>1); merge uniq cmp wasc ys zz ws (if wn = 0 then 0 else wn - 1)) - else if (wasc < 0) = (res < 0) then merge uniq cmp wasc ys zz (y::ws) wn else merge uniq cmp wasc yy zs (z::ws) wn in - let rec merge1 uniq cmp ys yn yasc zss = match zss with - | [] -> None - | (z::zs' as zs,zn,zasc)::zss as orig -> (match ys with - | [] -> assert false - | y::ys' -> - (* yn = 0 forces collapse of stack *) - if yn > 0 && yn*2 <= zn then None - else let wn = if yn > 0 then yn + zn else 0 in - if yasc = 0 then (assert (yn <= 1); merge2 uniq cmp zss (merge uniq cmp zasc ys zs [] wn)) - else let res = cmp y z in - let () = assert (yn <> 1) in - if uniq && res = 0 then (if yn = 1 then merge2 uniq cmp zss (zs,zn,zasc) else merge1 uniq cmp ys' (if yn = 0 then 0 else yn - 1) yasc orig) - else if yasc < 0 && zasc > 0 && res >= 0 then merge2 uniq cmp zss (rev1 zs ys, wn, 1) - else if yasc > 0 && zasc < 0 && res < 0 then merge2 uniq cmp zss (rev1 ys zs, wn, 1) - else let wasc,ys,zs = if (yasc < 0) = (zasc < 0) then zasc, ys, zs else if zn < yn then yasc, ys, rev1 [] zs else zasc, rev1 [] ys, zs in - merge2 uniq cmp zss (merge uniq cmp wasc ys zs [] wn)) - | _ -> assert false - and merge2 uniq cmp zss (ws,wn,wasc) = - let more = merge1 uniq cmp ws wn wasc zss in - match more with None -> Some ((ws,wn,wasc)::zss) | _ -> more in - (* yasc = -1 when a segment of the original list was strictly descending, +1 when it was non-descending, 0 when the segment is only 1 member long *) - let rec step uniq cmp xs y ys yn yasc zss = - match xs with - | (x::xs) -> - let res = cmp x y in - if uniq && res = 0 then step uniq cmp xs y ys yn yasc zss - else if yn = 1 then step uniq cmp xs x (y::ys) 2 (if res < 0 then -1 else 1) zss - else (assert (yasc <> 0); if (yasc < 0) = (res < 0) then step uniq cmp xs x (y::ys) (yn+1) yasc zss - else step uniq cmp xs x [] 1 0 (match merge1 uniq cmp (y::ys) yn yasc zss with None -> (y::ys,yn,yasc)::zss | Some zss -> zss)) - | [] -> (* finished stepping through original list, use yn = 0 to force merge1 until completion *) - (match merge1 uniq cmp (y::ys) 0 yasc zss with - | Some [(ys,0,yasc)] -> if yasc > 0 then rev1 [] ys else ys - | None -> if yasc > 0 then rev1 [y] ys else y::ys - | _ -> assert false) in - match many,rev,xs with - | _,_,[] | _,_,[_] -> xs - | None,None,x::xs -> step true cmp xs x [] 1 0 [] - | Some _,None,x::xs -> step false cmp xs x [] 1 0 [] - | None,Some _,x::xs -> step true (fun x y -> -cmp x y) xs x [] 1 0 [] - | Some _,Some _,x::xs -> step false (fun x y -> -cmp x y) xs x [] 1 0 [] - - let is_sorted ?(cmp=compare) ?many ?rev xs = - let rec aux cmp thresh y = function - | [] -> true - | x::xs -> cmp y x < thresh && aux cmp thresh x xs in - match rev,xs with - | _,[] | _,[_] -> true - | None,x::xs -> aux cmp (match many with None -> 0 | Some _ -> 1) x xs - | Some _,x::xs -> aux (fun x y -> -cmp x y) (match many with None -> 0 | Some _ -> 1) x xs - - - let string_of_list ?(brackets=true) ?(sep=";") f xs = - let rec aux sep' = function [] -> if brackets then "]" else "" | x::xs -> sep' ^ f x ^ aux sep xs in - (if brackets then "[" else "") ^ aux "" xs - - let histogram ?(eq=(=)) xs = fold_left (fun h x -> modify_assoc x (fun _ n -> n+1) ~missing:(fun _ -> 1) ~eq h) [] xs - - let pairwise ?missing xs = - let rec aux missing x = function - | [] -> (match missing with None -> [] | Some y -> [(x,y)]) - | y::ys -> (x,y)::aux missing y ys in - match xs with - | [] -> [] - | x::xs -> aux missing x xs - - let rec round_robin xss = - let rec aux ws ys = function - | [] -> (match ys with [] -> rev1 [] ws | _ -> aux ws [] (rev1 [] ys)) - | []::xss -> aux ws ys xss - | (x::xs)::xss -> aux (x::ws) (xs::ys) xss in - match xss with - | [] -> raise Short_list - | []::xss -> round_robin xss - | xss -> aux [] [] xss - - let rec chunk n xs = match split n xs with - | ys,[] -> [ys] - | ys,zs -> ys::chunk n zs - - let rec chunk' n xs = match split' n xs with - | ys,[] -> [ys] - | ys,zs -> ys::chunk' n zs - - let chunk_int n xs = - let rec aux n = function - | _ when n = 0 -> [[]] - | [] -> [] - | x::xs as orig -> if x > n then aux n xs else map ~onto:(aux n xs) (cons x) (aux (n-x) orig) in - let xs = sort ~many xs in - match sort xs with x::_ as xs when x > 0 && n > 0 -> aux n (rev1 [] xs) | _ -> invalid_arg "chunk_int" - - let chunk_range sizes = - let rec combs2 k = function - | xs when k = 0 -> [([],xs)] - | [] -> [] - | x::xs -> map (fun (cs,zs) -> x::cs,zs) (combs2 (k-1) xs) ~onto:(map (fun (cs,zs) -> cs,x::zs) (combs2 k xs)) in - let rec p xs = function - | [] -> [[]] - | k::ks -> catmap (fun (cs,zs) -> map (cons cs) (p zs ks)) (combs2 k xs) in - if exists (fun x -> x<0) sizes then invalid_arg "chunk_range" else p (range_until 0 (sum sizes)) sizes - - end (* List *) - - let short = List.short - let many = List.many - exception Short_list = List.Short_list - - let is_null = List.is_null - let length = List.length - let cons = List.cons - let snoc = List.snoc - let singleton = List.singleton - let head = List.head - let opthead = List.opthead - let tail = List.tail - let tail' = List.tail' - let uncons = List.uncons - let append = List.append - let concat = List.concat - let rev = List.rev - let zip = List.zip - let unzip = List.unzip - let iter = List.iter - let iteri = List.iteri - let iter2 = List.iter2 - let fold_left = List.fold_left - let fold_left1 = List.fold_left1 - let fold_left2 = List.fold_left2 - let fold_right = List.fold_right - let fold_right1 = List.fold_right1 - let fold_right2 = List.fold_right2 - let for_all = List.for_all - let exists = List.exists - let for_all2 = List.for_all2 - let exists2 = List.exists2 - let sum = List.sum - let product = List.product - let take = List.take - let take' = List.take' - let drop = List.drop - let drop' = List.drop' - let split = List.split - let split' = List.split' - let nth = List.nth - -(* - count - make - last - init - init' - mem - map - map2 - unmap2 - mapi - optmap - optmapi - catmap - catmapi - maximum - minimum - maxby - minby - modify - optmodify - catmodify - take_while - drop_while - split_while - find - optfind - findx - index - remove - delete - pick - pickx - filter - filterx - indices - partition - partitionx - assoc - mem_assoc - modify_assoc - optmodify_assoc - remove_assoc - memq - indexq - deleteq - indicesq - assq - mem_assq - modify_assq - optmodify_assq - remove_assq - rotate - unfold - mapz - group - cross - insert - select - range - range_until - unique - is_unique - transpose - permutations - sublists - is_sublist - is_subset - is_eqset - lexcmp - diff - union - intersect - merge - sort - is_sorted - string_of_list - histogram - pairwise - round_robin - chunk - chunk' - chunk_int - chunk_range -*) - - let factorial n = let rec aux m = function 0 -> m | 1 -> m | n -> aux (n*m) (n-1) in aux 1 n - - (* good to around n = 28; naive version overflows after n = 20 *) - let choose n k = let j = max k (n-k) in if j = n then 1 else List.fold_left (/) (List.product (List.range_until n j)) (List.range_until (n-j) 1) - - module Random : sig - val init : ?seed:int -> unit -> unit - val bool : unit -> bool - (* start <= result < stop *) - val between : int -> int -> int - val nth : 'a list -> 'a - val pick : 'a list -> 'a * 'a list - (* k dice rolls are `permutation ~len:k ~many [1..6]` *) - val permutation : ?len:int -> ?many:'b -> 'a list -> 'a list - (* choose k elements from xs, in stable order, ~many with replacment *) - val sublist : len:int -> ?many:'b -> 'a list -> 'a list - end = struct - - let init ?seed () = - match seed with - | None -> Std.Random.self_init() - | Some n -> Std.Random.init n - - let bool = Std.Random.bool - - let between start stop = Std.Random.int (stop-start) + start - - let nth xs = match List.length xs with - | 0 -> invalid_arg "Random.nth" - | n -> List.nth xs (between 0 n) - - let pick xs = - let rec aux n ws = function - | x::xs -> if n = 0 then x, List.rev ~onto:xs ws else aux (n-1) (x::ws) xs - | [] -> assert false in - match List.length xs with - | 0 -> invalid_arg "Random.pick" - | n -> aux (between 0 n) [] xs - - let permutation ?len ?many xs = - (* a[j],a[n] = x,a[j] *) - let array_push a j n x = if j = n then a.(n) <- x else let y = a.(j) in (a.(j) <- x; a.(n) <- y) in - (* return,a[j] = a[j],a[n] *) - let array_pop a j n = let y = a.(n-1) in if j = n - 1 then y else (let x = a.(j) in a.(j) <- y; x) in - let rec aux_all a n = function - (* Based on https://en.wikipedia.org/wiki/Fisher-Yates_shuffle#The_.22inside-out.22_algorithm - Initialize empty array to shuffled copy of xs *) - | [] -> Array.to_list a - | x::xs -> let j = between 0 (n+1) in (array_push a j n x; aux_all a (n+1) xs) in - let rec aux_fixed k n a ws = function - | 0 -> ws - | i -> let j = between 0 n in let w = array_pop a j n in aux_fixed k (n-1) a (w::ws) (i-1) in - match len,many,xs with - | None,_,[] -> [] - | Some k,_,[] -> if k = 0 then [] else invalid_arg "Random.permutation" - | None,None,x::_ -> aux_all (Array.make (List.length xs) x) 0 xs - | Some k,None,_ -> if k < 0 then invalid_arg "Random.permutation" else aux_fixed k (List.length xs) (Array.of_list xs) [] k - | Some k,Some _,_ -> if k < 0 then invalid_arg "Random.permutation" else iterate k (fun ys -> nth xs::ys) [] - | None,Some _,_ -> invalid_arg "Random.permutation ~many requires ~len" - - let sublist ~len:k ?many xs = - let rec aux_fixed ws n k = function - | _ when k = 0 -> List.rev ws - | (x::xs) -> - (* Explanation of the threshhold: There are n choose k many combinations, yes=(n-1) choose (k-1) headed by element x and no=(n-1) choose k not. - So x has yes/(yes+no) chance of occupying initial slot, else it occupies none of the slots. yes/(yes+no) reduces to k/n. *) - if between 0 n < k then aux_fixed (x::ws) (n-1) (k-1) xs else aux_fixed ws (n-1) k xs - | _ -> assert false in - let rec aux_replacing k top ws = function - | _ when k = 0 -> List.rev ws - | [] -> [] (* will only happen when xs was [] to start with *) - | x::xs as orig -> - (* Explanation of the threshhold: There are n+k-1 choose k many combinations with replacement, yes=(n+k-2) choose (k-1) headed by element x and no=(n+k-2) choose k not. - So x has yes/(yes+no) chance of occupying the initial slot, and also possibly some later slots. This reduces to k/(k+n-1). *) - if between 0 (k+top) < k then aux_replacing (k-1) top (x::ws) orig else aux_replacing k (top-1) ws xs in - let n = List.length xs in - if k < 0 || k > n then invalid_arg "Random.sublist" - else match many with - | None -> aux_fixed [] n k xs - | Some _ -> aux_replacing k (n-1) [] xs - - end (* Random *) - - (* #load "Str.cma";; *) - module String : sig - type t = string - val compare : 'a -> 'a -> int - val length : string -> int - val take : int -> ?rev:'a -> string -> string - val drop : int -> string -> string - val sub : string -> int -> len:int -> string - val is_prefix : string -> string -> bool - val is_suffix : string -> string -> bool - val is_infix : string -> string -> bool - val find : string -> ?rev:'a -> ?from:int -> string -> int - val nth : string -> int -> char - val make : int -> char -> string - val mem : char -> ?rev:'a -> ?from:int -> string -> bool - val index : ?rev:'a -> ?from:int -> char -> string -> int - val upper : string -> string - val lower : string -> string - val int_of_char : char -> int - val char_of_int : int -> char - (* trim only removes up to 1 leading/trailing occurrence of pat *) - val trim : string -> string - type pat = string - val split : string -> ?n:int -> ?trim:'a -> pat -> string list - val join : sep:string -> string list -> string - val lines : ?trim:'a -> string -> string list (* as in Haskell, gobbles up to 1 \n per line *) - val words : string -> string list - val unlines : string list -> string (* as in Haskell, does add a trailing \n *) - val unwords : string list -> string (* as in Haskell, no trailing space *) - end = struct - type t = string - let compare = compare - let length = Std.String.length - let take n ?rev s = match rev with - | None -> Str.string_before s n - | Some _ -> Str.last_chars s n - let drop n s = Str.string_after s n - let sub s start ~len = Std.String.sub s start len - let is_prefix (sought : string) s = let n = length sought in length s >= n && take n s = sought - let is_suffix (sought : string) s = let n = length sought in length s >= n && take n ~rev:() s = sought - let is_infix (sought : string) s = length sought <= length s && try Str.(search_forward (regexp_string sought) s 0) >= 0 with Not_found -> false - let find (sought : string) ?rev ?from s = match rev,from with - | None,None -> Str.(search_forward (regexp_string sought) s 0) - | None,Some n -> Str.(search_forward (regexp_string sought) s n) - | Some _,Some n -> Str.(search_backward (regexp_string sought) s n) - | Some _,None -> let n = length s - length sought in if n < 0 then raise Not_found else Str.(search_backward (regexp_string sought) s n) - let nth s n = Std.String.get s n - let make n c = Std.String.make n c - let mem (sought : char) ?rev ?from s = match rev,from with - | None,None -> Std.String.contains s sought - | None,Some n -> Std.String.contains_from s n sought - | Some _,Some n -> Std.String.rcontains_from s n sought - | Some _,None -> invalid_arg "String.mem ~rev requires ~from" - let index ?rev ?from (sought : char) s = match rev,from with - | None,None -> Std.String.index s sought - | Some _,None -> Std.String.rindex s sought - | None,Some n -> Std.String.index_from s n sought - | Some _,Some n -> Std.String.rindex_from s n sought - let upper s = Std.String.uppercase s - let lower s = Std.String.lowercase s - let int_of_char (c : char) = Std.Char.code c - let char_of_int (n : int) = Std.Char.chr n - let trim s = Std.String.trim s - type pat = string - let split s ?n ?trim pat = match n,trim with - | None,Some _ -> Str.(split (regexp pat) s) - | Some n,Some _ -> Str.(bounded_split (regexp pat) s n) - | None,None -> Str.(split_delim (regexp pat) s) - | Some n,None -> Str.(bounded_split_delim (regexp pat) s n) - let join ~sep ss = Std.String.concat sep ss - let lines ?trim s = split ("\n"^s) ~trim "\n" - let words s = split s ~trim "[ \t\n]+" - let unlines ss = join "\n" ss ^ "\n" - let unwords ss = join " " ss - end (* String *) - -end (* Juli8 *) - -open Juli8 - -#use "monad.ml" diff --git a/code/monad.ml b/code/monad.ml deleted file mode 100644 index f17d953b..00000000 --- a/code/monad.ml +++ /dev/null @@ -1,1186 +0,0 @@ -(* 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 - type 'a ut - include MONAD - val hoist : 'a ut -> 'a t - end - - module type ZERO = sig - type 'a t - (* 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 MONADZERO = sig - include MONAD - include ZERO with type 'a t := 'a t - end - - module type MONADZEROT = sig - include MONADT - include ZERO with type 'a t := '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 result = 'a B.result and type 'a ut := 'a B.U.t = 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 result = 'a B.result and type 'a ut := 'a B.U.t = 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 result = 'a B.result and type 'a ut := 'a B.U.t = 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 type OPTION = sig - include MONADZERO with type 'a result = 'a option - val test : ('a option -> bool) -> 'a t -> 'a t - end - - module type OPTIONT = sig - type 'a uresult - include MONADT with type 'a result = 'a option uresult - val test : ('a option ut -> bool) -> 'a t -> 'a t - end - - 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 : OPTION = 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) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 type LIST = sig - include MONADZERO with type 'a result = 'a list - 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 -> bool) -> 'a t -> 'a t - end - - module type LISTT = sig - type 'a uresult - include MONADZEROT with type 'a result = 'a list uresult - 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 ut -> bool) -> 'a t -> 'a t - (* - Monadically seq k over box. - 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 ut) -> 'a list -> 'b t - end - - module List = struct - include Juli8.List - 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 : LIST = 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) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 type TREE = sig - type 'a tree - include MONAD with type 'a result = 'a tree - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - end - - module type TREET = sig - type 'a tree - type 'a uresult - include MONADT with type 'a result = 'a tree uresult - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - (* - Monadically seq k over box. - 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 ut) -> 'a tree -> 'b t - end - - 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 M : TREE with type 'a tree := 'a tree = 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) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a 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 - - - module type READER = sig - type env - include MONAD with type 'a result = env -> 'a - val ask : env t - val asks : (env -> 'a) -> 'a t - val shift : (env -> env) -> 'a t -> 'a t - end - - module type READERT = sig - type env - type 'a uresult - include MONADT with type 'a result = env -> 'a uresult - val ask : env t - val asks : (env -> 'a) -> 'a t - val shift : (env -> env) -> 'a t -> 'a t - end - - (* must be parameterized on `struct type env = ... end` *) - module Reader(E : sig type env end) = struct - type env = E.env - module M : READER with type env := env = 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) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO 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 *) - - - module type STATE = sig - type store - include MONAD with type 'a result = store -> 'a * store - val get : store t - val gets : (store -> 'a) -> 'a t - val put : store -> unit t - val modify : (store -> store) -> unit t - end - - module type STATET = sig - type store - type 'a uresult - include MONADT with type 'a result = store -> ('a * store) uresult - val get : store t - val gets : (store -> 'a) -> 'a t - val put : store -> unit t - val modify : (store -> store) -> unit t - end - - (* must be parameterized on `struct type store = ... end` *) - module State(S : sig type store end) = struct - type store = S.store - module M : STATE with type store := store = 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) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO 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 *) - - - module type REF = sig - type ref - type value - include MONAD with type 'a result = 'a - val newref : value -> ref t - val deref : ref -> value t - val change : ref -> value -> unit t - end - - module type REFT = sig - type ref - type value - type 'a uresult - include MONADT with type 'a result = 'a uresult - val newref : value -> ref t - val deref : ref -> value t - val change : ref -> value -> unit t - end - - (* 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 M : REF with type value := value and type ref := ref = 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) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO 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 *) - - - module type WRITER = sig - type log - include MONAD with type 'a result = 'a * log - 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 type WRITERT = sig - type log - type 'a uresult - include MONADT with type 'a result = ('a * log) uresult - 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 - - (* 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 M : WRITER with type log := log = 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) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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 WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO 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 *) - - - module type ERROR = sig - type msg - type 'a error - include MONAD with type 'a result = 'a error - val throw : msg -> 'a t - val catch : 'a t -> (msg -> 'a t) -> 'a t - end - - module type ERRORT = sig - type msg - type 'a error - type 'a uresult - include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *) - val throw : msg -> 'a t - val catch : 'a t -> (msg -> 'a t) -> 'a t - end - - (* must be parameterized on `struct type msg = ... end` *) - module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct - type msg = E.msg - type 'a error = Error of msg | OK of 'a - module M : ERROR with type msg := msg and type 'a error := 'a error = struct - include Make.MonadFromBind(struct - type 'a t = 'a error - type 'a result = 'a t - (* note that M.run doesn't raise *) - 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) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = 'a error U.t - type 'a result = 'a U.result - (* note that T.run does raise *) - 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 ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO 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 = if s2 = "" then s1 else if s1 = "" then s2 else 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 msg = string exception Exc = Failure end) - -end (* Monad *) - -module Option = Monad.Option -module List = Monad.List - diff --git a/code/reader2.ml b/code/reader2.ml index 10d61e3e..bf561aad 100644 --- a/code/reader2.ml +++ b/code/reader2.ml @@ -4,8 +4,8 @@ module rec E : sig end = E and R : Monad.READER with type env = E.env = struct type env = E.env - module Made = Monad.Reader(E) - include Made.M + module R_E = Monad.Reader(E) + include = R_E.M end @@ -33,5 +33,5 @@ let letf ff body = R.(ff >>= fun f -> shift (insert 'f' (E.Fun f)) body) (* monadic version of `let x = 2 in let f = \y -> y + x in f 3` *) let (expr4 : int R.t) = R.(letx (mid 2) (letf (mid lambda1) (getf >>= fun f -> f (mid 3)))) -let res = R.run expr4 env0 +let res = R.run expr4 env0 (* will be 5 *)