package fmlib_std

  1. Overview
  2. Docs

Source file rb_array.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
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
module type BITSIZE =
sig
    val bitsize: int
end




module Make (Bitsize: BITSIZE) =
struct
    include Bitsize

    let branching: int =
        assert (0 < bitsize);
        1 lsl bitsize


    let slot (i: int) (l: int): int =
        (* The slot of index [i] at level [l].

            i/ 2^(l * bitsize)
         *)
        i lsr (l * bitsize)


    let offset (i: int) (s: int) (l: int): int =
        (* The offset of index [i] in slot [s] in a tree at level [l].

            i- s * 2^(l * bitsize)
         *)
        i - s lsl (l * bitsize)


    let full_size (l: int): int =
        (* The size of a full radix balanced array at level [l]. *)
        assert (0 <= l);
        1 lsl ((l + 1) * bitsize)


    type 'a t =
        | Leaf of
            'a array
        | Node of {
            size:  int;
            level: int;
            nodes: 'a t array}


    let level: 'a t -> int = function
        | Leaf _ ->
            0
        | Node node ->
            node.level


    let is_full: 'a t -> bool = function
        | Leaf arr ->
            Array.length arr = full_size 0
        | Node node ->
            node.size = full_size node.level


    let length: 'a t -> int =
        (* The length of the radix balanced array. *)
        function
        | Leaf arr ->
            Array.length arr
        | Node node ->
            node.size


    let has_some (t: 'a t): bool =
        0 < length t


    let is_empty (t: 'a t): bool =
        0 = length t



    let check_invariant (t: 'a t):  bool =
        let rec check is_root = function
            | Leaf arr ->
                let len = Array.length arr in
                len <= branching
                &&
                (is_root || 0 < len)
            | Node node ->
                let nchildren = Array.length node.nodes
                in
                Array.for_all (check false) node.nodes
                &&
                Array.for_all
                    (fun child -> level child + 1 = node.level)
                    node.nodes
                &&
                nchildren <= branching
                &&
                1 <= nchildren
                &&
                (not is_root || 2 <= nchildren)
                &&
                (
                    node.size
                    =
                    Array.fold_left
                        (fun size child -> size + length child)
                        0
                        node.nodes
                )
        in
        check true t


    let empty: 'a t =
        Leaf [| |]



    (* Folding
     *)

    let fold_left (f: 'a -> 'b -> 'a) (start: 'a) (t: 'b t): 'a =
        let rec fold start = function
            | Leaf arr ->
                Array.fold_left f start arr
            | Node node ->
                Array.fold_left fold start node.nodes
        in
        fold start t



    let foldi_left (f: 'a -> int -> 'b -> 'a) (start: 'a) (t: 'b t): 'a =
        fold_left
            (fun (start,idx) e -> f start idx e, (idx + 1))
            (start, 0)
            t
        |>
        fst



    (* Element Retrieval
     *)

    let rec element (i: int) (t: 'a t): 'a =
        (* The element at index [i] in the radix balanced array [t]. *)
        assert (0 <= i);
        assert (i < length t);
        match t with
        | Leaf arr ->
            arr.(i)
        | Node node ->
            let s = slot i node.level in
            let o = offset i s node.level in
            element o node.nodes.(s)


    let first (t: 'a t): 'a =
        (* The first element of the non empty radix balanced array [t]. *)
        assert (has_some t);
        let rec fst = function
            | Leaf arr ->
                Array.first arr
            | Node node ->
                fst (Array.first node.nodes)
        in
        fst t


    let last (t: 'a t): 'a =
        (* The last element of the non empty radix balanced array [t]. *)
        assert (has_some t);
        let rec fst = function
            | Leaf arr ->
                Array.last arr
            | Node node ->
                fst (Array.last node.nodes)
        in
        fst t



    (* Element Replacement
     *)


    let rec replace (i: int) (e: 'a) (t: 'a t): 'a t =
        (* Replace the element at index [i] by the element [e] within the radix
           balanced array [t]. *)
        assert (0 <= i);
        assert (i < length t);
        match t with
        | Leaf arr ->
            Leaf (Array.replace i e arr)
        | Node node ->
            let s = slot i node.level in
            let o = offset i s node.level in
            Node
                {node with
                    nodes =
                        Array.replace
                            s
                            (replace o e node.nodes.(s))
                            node.nodes
                }






    (* Element Insertion at the Rear End
     *)

    let rec singleton_tree (lev: int) (e: 'a): 'a t =
        (* Construct tree at level [lev] with the element [e]. *)
        if lev = 0 then
            Leaf [| e |]
        else
            Node {
                size = 1;
                level = lev;
                nodes = [| singleton_tree (lev - 1) e |]
            }


    let rec push_not_full (e: 'a) (t: 'a t): 'a t =
        (* Append the element [e] at the rear end of the radix balanced array
           [t] which is not full. *)
        assert (not (is_full t));
        match t with
        | Leaf arr ->
            Leaf (Array.push e arr)

        | Node node ->
            let slot = Array.length node.nodes - 1 in
            assert (0 <= slot);
            let nodes =
                if is_full node.nodes.(slot) then
                    Array.push
                        (singleton_tree (node.level - 1) e)
                        node.nodes
                else
                    Array.replace
                        slot
                        (push_not_full e node.nodes.(slot))
                        node.nodes
            in
            Node
                {node with nodes; size = node.size + 1}


    let push (e: 'a) (t: 'a t): 'a t =
        (* Append the element [e] at the rear end of the radix balanced array
           [t]. *)
        let lev = level t
        and len = length t
        in
        if len = full_size lev then
            Node {
                size  = len + 1;
                level = lev + 1;
                nodes = [| t; singleton_tree lev e|]
            }
        else
            push_not_full e t







    (* Element Removal from the Rear End
     *)


    let rec pop_aux (is_root: bool) (t: 'a t): 'a * 'a t =
        (* Remove the last element from a nonempty tree. *)
        assert (has_some t);
        match t with
        | Leaf arr ->
            Array.(last arr, Leaf (remove_last arr))
        | Node node ->
            let j = Array.length node.nodes - 1 in
            assert (0 <= j);
            let child = node.nodes.(j) in
            let len   = length child in
            if is_root && j = 1 && len = 1 then
                (* Last child of the root node has only one element. *)
                last child,
                node.nodes.(0)
            else
                let e, nodes =
                    if len = 1 then
                        (* Last child has only one element. *)
                        last child,
                        Array.remove_last node.nodes
                    else
                        (* Normal case. *)
                        let e, child = pop_aux false child in
                        e,
                        Array.replace j child node.nodes
                in
                e,
                Node {
                    node with
                    size = node.size - 1;
                    nodes
                }


    let pop (t: 'a t): 'a * 'a t =
        assert (has_some t);
        pop_aux true t


    let pop_opt (t: 'a t): ('a * 'a t) option =
        if is_empty t then
            None
        else
            Some (pop_aux true t)
end




module Branching2: BITSIZE =
struct
    let bitsize: int = 1
end


module Branching32: BITSIZE =
struct
    let bitsize: int = 5
end



include Make (Branching32)







(* Unit Tests
 * **********
 *)
module Rb = Make (Branching2)


let fill (start: int) (beyond: int): int Rb.t =
    assert (start <= beyond);
    let rec fl start t =
        if start = beyond then
            t
        else
            fl (start + 1) (Rb.push start t)
    in
    fl start Rb.empty


let check_fill (start: int) (beyond: int): bool =
    let rec check start t =
        if start = beyond then
            Rb.check_invariant t
        else
            Rb.check_invariant t
            &&
            check (start + 1) (Rb.push start t)
    in
    check start Rb.empty


let check_fold (start: int) (beyond: int) (t: int Rb.t): bool =
    start + Rb.length t = beyond
    &&
    Rb.foldi_left
        (fun ok idx e ->
             ok && e = start + idx)
        true
        t


let check_element (start: int) (beyond: int) (t: int Rb.t): bool =
    let rec check_from i start =
        if start = beyond then
            true
        else
            start = Rb.element i t
            &&
            check_from (i + 1) (start + 1)
    in
    check_from 0 start



let check_pop (start: int) (beyond: int) (t: int Rb.t): bool =
    let rec check beyond t =
        Rb.check_invariant t
        &&
        (
            if beyond = start then
                Rb.is_empty t
            else
                Rb.has_some t
                &&
                let e, t = Rb.pop t in
                e + 1 = beyond
                &&
                check (beyond - 1) t
        )
    in
    check beyond t



let%test _ =
    let start = 10
    and beyond = 100
    in
    check_fill start beyond


let%test _ =
    let start = 10
    and beyond = 100
    in
    check_fold start beyond (fill start beyond)


let%test _ =
    let start = 10
    and beyond = 100
    in
    check_pop start beyond (fill start beyond)



let%test _ =
    let start = 10
    and beyond = 100
    in
    check_element start beyond (fill start beyond)



let%test _ =
    Rb.(check_invariant empty)


let%test _ =
    Rb.check_invariant (fill 0 25)
OCaml

Innovation. Community. Security.