1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
module Ordering = struct
type t = Equal | Smaller | Greater
let of_int x = if x < 0 then Smaller else if x > 0 then Greater else Equal
end
module Option = struct
let ( let* ) = Option.bind
let ( |>> ) = Option.bind
let sequence = function None -> Ok None | Some x -> Result.map Option.some x
end
module Result = struct
let ( let* ) = Result.bind
let ( |>> ) = Result.bind
end
module type SEQUENCE = sig
type 'a t
val empty : 'a t
val cons : 'a -> 'a t -> 'a t
val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
end
module Generic (S : SEQUENCE) = struct
let sequence ms =
let open Result in
S.fold_right
(fun m acc ->
let* acc = acc in
let* m = m in
Ok (S.cons m acc) )
ms (Ok S.empty)
let foldm_left f init ms =
let open Result in
S.fold_left
(fun acc m ->
let* acc = acc in
f acc m )
(Ok init) ms
end
module List = struct
module ListSequence : SEQUENCE with type 'a t = 'a list = struct
type 'a t = 'a list
let empty = []
let cons x xs = x :: xs
let fold_right = List.fold_right
let fold_left = List.fold_left
end
include Generic (ListSequence)
let concat_mapm f xs = List.map f xs |> sequence |> Stdlib.Result.map List.concat
let hd_opt = function x :: _ -> Some x | [] -> None
end
module FingerTree = struct
module FingerTreeSequence : SEQUENCE with type 'a t = 'a BatFingerTree.t = struct
type 'a t = 'a BatFingerTree.t
let empty = BatFingerTree.empty
let cons x xs = BatFingerTree.cons xs x
let fold_right f xs acc = BatFingerTree.fold_right (Fun.flip f) acc xs
let fold_left = BatFingerTree.fold_left
end
include Generic (FingerTreeSequence)
let map2 f xs ys =
let rec frob xs ys acc =
match BatFingerTree.front xs with
| None -> acc
| Some (xs', x) -> (
match BatFingerTree.front ys with
| None -> acc
| Some (ys', y) -> f x y |> BatFingerTree.snoc acc |> frob xs' ys' )
in
frob xs ys BatFingerTree.empty
let zip xs ys = map2 (fun x y -> x, y) xs ys
let join ss sep =
BatFingerTree.print ~first:"" ~last:"" ~sep BatIO.nwrite |> Fun.flip BatIO.to_string ss
let filter_map f =
BatFingerTree.fold_left
(fun acc elem ->
match f elem with None -> acc | Some result -> BatFingerTree.snoc acc result)
BatFingerTree.empty
let concat xss = BatFingerTree.fold_left BatFingerTree.append BatFingerTree.empty xss
let concat_mapm f xs = BatFingerTree.map f xs |> sequence |> Stdlib.Result.map concat
let rec sort (cmp : 'a -> 'a -> int) (input : 'a BatFingerTree.t) =
let open BatFingerTree in
let merge cmp l1 l2 =
let rec go acc l1 l2 =
match (front l1, front l2) with
| None, _ -> append acc l2
| _, None -> append acc l1
| Some (t1, h1), Some (t2, h2) ->
if cmp h1 h2 <= 0 then go (snoc acc h1) t1 l2
else go (snoc acc h1) l1 t2
in
go empty l1 l2
in
match size input with
| 0 | 1 -> input
| n ->
let left, right = split_at input (n / 2) in
merge cmp (sort cmp left) (sort cmp right)
let group (cmp : 'a -> 'a -> int) (ft : 'a BatFingerTree.t) : 'a BatFingerTree.t BatFingerTree.t =
let open BatFingerTree in
let sorted = sort cmp ft in
let fold first rest =
fold_left
(fun (acc, agr, last) elem ->
if cmp last elem = 0 then (acc, snoc agr elem, elem)
else (snoc acc agr, singleton elem, elem))
(empty, singleton first, first)
rest
in
match front sorted with
| None -> empty
| Some (tl, hd) ->
let groups, lastgr, _ = fold hd tl in
snoc groups lastgr
end
module Atomic = struct
let rec swap atom f =
let v = Atomic.get atom in
let v' = f v in
if Atomic.compare_and_set atom v v' then atom else swap atom f
let rec mswap atom f =
let open Result in
let v = Atomic.get atom in
let* v' = f v in
if Atomic.compare_and_set atom v v' then Ok atom else mswap atom f
end
module Fun = struct
let ( |.| ) = Fun.compose
end
|
