Source file do_random.ml
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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
open Plebeia
open Helper
open Cursor
open Node
module Flat = struct
let gen_segment = Gen.(segment @@ int_range (3,5))
let do_random ?(no_commit=false) st sz c dumb =
let segs = ref SegmentSet.empty in
let add_seg seg = segs := SegmentSet.add seg !segs in
let del_seg seg = segs := SegmentSet.remove seg !segs in
let pick_seg st =
let segs = SegmentSet.elements !segs in
let len = List.length segs in
if len < 20 then gen_segment st
else
let pos = RS.int st (List.length segs) in
List.nth segs pos
in
let rev_ops = ref [] in
let add_op o = rev_ops := o :: !rev_ops in
let rec f c dumb i =
if i = sz then (c, dumb)
else
let (c, dumb) =
let op = match RS.int st (if no_commit then 7 else 8) with
| 0 -> `Insert (gen_segment st, Gen.value st)
| 1 -> `Upsert (gen_segment st, Gen.value st)
| 2 -> `Subtree (gen_segment st)
| 7 -> `Commit
| _ -> `Delete (pick_seg st)
in
begin match op with
| `Insert (sg, v) ->
Format.eprintf "insert %a %a@." Segment.pp sg Value.pp v
| `Upsert (sg, v) ->
Format.eprintf "upsert %a %a@." Segment.pp sg Value.pp v
| `Subtree sg ->
Format.eprintf "subtree %a@." Segment.pp sg
| `Commit -> Format.eprintf "commit@."
| `Delete sg ->
Format.eprintf "delete %a@." Segment.pp sg
end;
match op with
| `Insert (seg, v) ->
begin match
insert c seg v,
Dumb.insert dumb seg v
with
| Ok c, Ok dumb ->
compare_trees dumb c;
let Cursor (_, n, context, _) = c in
validate_node context n;
add_op op;
add_seg seg;
(c, dumb)
| Error _, Error _ ->
(c, dumb)
| _ -> assert false
end
| `Upsert (seg, v) ->
begin match
upsert c seg v,
Dumb.upsert dumb seg v
with
| Ok c, Ok dumb ->
compare_trees dumb c;
let Cursor (_, n, context, _) = c in
validate_node context n;
add_op op;
add_seg seg;
(c, dumb)
| Error _, Error _ ->
(c, dumb)
| _ -> assert false
end
| `Subtree seg ->
begin match
create_subtree c seg,
Dumb.create_subtree dumb seg
with
| Ok c, Ok dumb ->
compare_trees dumb c;
let Cursor (_, n, context, _) = c in
validate_node context n;
add_op op;
add_seg seg;
(c, dumb)
| Error _, Error _ ->
(c, dumb)
| _ -> assert false
end
| `Delete seg ->
begin match
delete c seg,
Dumb.delete dumb seg
with
| Ok c, Ok dumb ->
compare_trees dumb c;
let Cursor (_, n, context, _) = c in
validate_node context n;
add_op op;
del_seg seg;
(c, dumb)
| Error _, Error _ ->
(c, dumb)
| _ -> assert false
end
| `Commit ->
let Cursor(_, _, context, info), i, _ = from_Ok @@ Cursor_storage.write_top_cursor c in
let v = Node_storage.read_node context i Not_Extender in
add_op op;
(_Cursor (_Top, View v, context, info), dumb)
in
f c dumb (i+1)
in
let (c,_) = f c dumb 0 in
(List.rev !rev_ops, Cursor_storage.read_fully ~reset_index:false c)
end
module Deep = struct
let gen_segments = gen_segments (1,5) 3
let do_random st sz c =
let rev_ops = ref [] in
let add_op o = rev_ops := o :: !rev_ops in
let rec f c i =
if i = sz then c
else
let c =
let rec get_op () = match RS.int st 8 with
| 0 -> `Insert (gen_segments st, Gen.value st)
| 1 -> `Upsert (gen_segments st, Gen.value st)
| 2 -> `Subtree (gen_segments st)
| 3 -> `Commit
| 4 ->
begin match random_segs_to_bud_or_leaf st c with
| None -> get_op ()
| Some segs ->
let segs' = gen_segments st in
`Copy (segs, segs')
end
| _ ->
match random_segs_to_bud_or_leaf st c with
| None -> get_op ()
| Some segs -> `Delete segs
in
let op = get_op () in
match op with
| `Insert (segs, v) ->
begin match Deep.insert c segs v with
| Ok c ->
add_op op;
check_cursor_is_top c;
c
| Error _ -> c
end
| `Upsert (segs, v) ->
begin match Deep.upsert c segs v with
| Ok c ->
add_op op;
check_cursor_is_top c;
c
| Error _ -> c
end
| `Subtree segs ->
begin match Deep.create_subtree ~create_subtrees:true c segs with
| Ok c ->
add_op op;
check_cursor_is_top c;
c
| Error _ -> c
end
| `Delete segs ->
begin match
Deep.delete c segs
with
| Ok c ->
add_op op;
check_cursor_is_top c;
c
| Error _ -> c
end
| `Copy (segs, segs') ->
begin match Deep.copy ~create_subtrees:true c segs segs' with
| Ok c ->
add_op op;
check_cursor_is_top c;
c
| Error _ -> c
end
| `Commit ->
let Cursor(_, _, context, info), i, _ = from_Ok @@ Cursor_storage.write_top_cursor c in
let v = Node_storage.read_node context i Not_Extender in
add_op op;
_Cursor (_Top, View v, context, info)
in
f c (i+1)
in
let c = f c 0 in
(c, List.rev !rev_ops)
end
module Vc = struct
open Lwt.Syntax
module Deep = Plebeia.Deep
let debug = false
let gen_segments = gen_segments (1,5) 3
let do_random rng sz vc =
let commits = Queue.create () in
let rec f parent c i =
if i = sz then Lwt.return c
else
let op =
let rec get_op () = match RS.int rng 8 with
| 0 -> `Insert (gen_segments rng, Gen.value rng)
| 1 -> `Upsert (gen_segments rng, Gen.value rng)
| 2 -> `Subtree (gen_segments rng)
| 3 ->
begin match random_segs_to_bud_or_leaf rng c with
| None -> get_op ()
| Some segs ->
let segs' = gen_segments rng in
`Copy (segs, segs')
end
| 4 | 5 ->
begin match random_segs_to_bud_or_leaf rng c with
| None -> get_op ()
| Some segs -> `Delete segs
end
| 6 -> `Commit
| 7 ->
if Queue.length commits > 0 then
`Checkout (Queue.take commits)
else get_op ()
| _ -> assert false
in
get_op ()
in
let* c, parent =
match op with
| `Insert (segs, v) ->
if debug then Format.eprintf "Insert at %a@." Segment.pp_segments segs;
Lwt.return begin match Deep.insert c segs v with
| Ok c ->
check_cursor_is_top c;
c, parent
| Error _ -> c, parent
end
| `Upsert (segs, v) ->
if debug then Format.eprintf "Upsert at %a@." Segment.pp_segments segs;
Lwt.return begin match Deep.upsert c segs v with
| Ok c ->
check_cursor_is_top c;
c, parent
| Error _ -> c, parent
end
| `Subtree segs ->
if debug then Format.eprintf "Create_subtree at %a@." Segment.pp_segments segs;
Lwt.return begin match Deep.create_subtree ~create_subtrees:true c segs with
| Ok c ->
check_cursor_is_top c;
c, parent
| Error _ -> c, parent
end
| `Delete segs ->
if debug then Format.eprintf "Delete at %a@." Segment.pp_segments segs;
Lwt.return begin match
Deep.delete c segs
with
| Ok c ->
check_cursor_is_top c;
c, parent
| Error _ -> c, parent
end
| `Copy (segs, segs') ->
if debug then Format.eprintf "Copy %a %a@." Segment.pp_segments segs Segment.pp_segments segs';
Lwt.return begin match Deep.copy ~create_subtrees:true c segs segs' with
| Ok c ->
check_cursor_is_top c;
c, parent
| Error _ -> c, parent
end
| `Commit ->
if debug then Format.eprintf "Commit@.";
let* c, _, commit = from_Ok_lwt @@ Vc.commit ~parent ~hash_override:None vc c in
Queue.add commit.hash commits;
Lwt.return (c, parent)
| `Checkout commit_hash ->
if debug then Format.eprintf "Checkout %a@." Commit_hash.pp commit_hash;
let* res = Vc.checkout vc commit_hash in
match res with
| None -> assert false
| Some c -> Lwt.return (c, Some commit_hash)
in
f parent c (i+1)
in
f None (Vc.empty vc) 0
end