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
type 'a digit =
| Zero
| One of 'a
| Two of 'a * 'a
| Three of 'a * 'a * 'a
type 'a t =
| Shallow of 'a digit
| Deep of { s : int
; f : 'a digit
; m : ('a * 'a) t Lazy.t
; r : 'a digit }
let empty = Shallow Zero
exception Empty
let _one x = Shallow (One x)
let _two x y = Shallow (Two (x, y))
let _deep s f m r =
assert (f <> Zero && r <> Zero);
Deep { s; f; m; r; }
let is_empty = function
| Shallow Zero -> true
| Shallow (One _ | Two _ | Three _) | Deep _ -> false
let _empty = Lazy.from_val empty
let rec push : 'a. 'a t -> 'a -> 'a t
= fun q x -> match q with
| Shallow Zero -> _one x
| Shallow (One y) -> Shallow (Two (y, x))
| Shallow (Two (y, z)) -> Shallow (Three (y, z, x))
| Shallow (Three (y, z, z')) ->
_deep 4 (Two (y, z)) _empty (Two (z', x))
| Deep { r = Zero; _ } -> assert false
| Deep { s; f; m; r = One y; } ->
_deep (s + 1) f m (Two (y, x))
| Deep { s; f; m; r = Two (y, z) } ->
_deep (s + 1) f m (Three (y, z, x))
| Deep { s; f; m = lazy q'; r = Three (y, z, z') } ->
_deep (s + 1) f (lazy (push q' (y, z))) (Two (z', x))
let map_last_digit f = function
| Zero -> Zero
| One x -> One (f x)
| Two (x, y) -> Two (x, f y)
| Three (x, y, z) -> Three (x, y, f z)
let map_last : 'a. ('a -> 'a) -> 'a t -> 'a t
= fun f -> function
| Shallow v ->
Shallow (map_last_digit f v)
| Deep ({ r; _ } as deep) ->
Deep { deep with r = map_last_digit f r }
let rec shift : 'a. 'a t -> ('a * 'a t)
= fun q -> match q with
| Shallow Zero -> raise Empty
| Shallow (One x) -> x, empty
| Shallow (Two (x, y)) -> x, Shallow (One y)
| Shallow (Three (x, y, z)) -> x, Shallow (Two (y, z))
| Deep { f = Zero; _ } -> assert false
| Deep { s; f = One x; m = lazy q'; r; } ->
if is_empty q'
then x, Shallow r
else
let (y, z), q' = shift q' in
x, _deep (s - 1) (Two (y, z)) (Lazy.from_val q') r
| Deep { s; f = Two (x, y); m; r; } ->
x, _deep (s - 1) (One y) m r
| Deep { s; f = Three (x, y, z); m; r; } ->
x, _deep (s - 1) (Two (y, z)) m r
let rec cons : 'a. 'a t -> 'a -> 'a t
= fun q x -> match q with
| Shallow Zero -> Shallow (One x)
| Shallow (One y) -> Shallow (Two (x, y))
| Shallow (Two (y, z)) -> Shallow (Three (x, y, z))
| Shallow (Three (y, z, z')) ->
_deep 4 (Two (x, y)) _empty (Two (z, z'))
| Deep { f = Zero; _ } -> assert false
| Deep { s; f = One y; m; r; } ->
_deep (s + 1) (Two (x, y)) m r
| Deep { s; f = Two (y, z); m; r; } ->
_deep (s + 1) (Three (x, y, z)) m r
| Deep { s; f = Three (y, z, z'); m = lazy q'; r; } ->
_deep (s + 1) (Two (x, y)) (lazy (cons q' (z, z'))) r
let _digit_to_seq d k = match d with
| Zero -> ()
| One x -> k x
| Two (x, y) -> k x; k y
| Three (x, y, z) -> k x; k y; k z
type 'a sequence = ('a -> unit) -> unit
let rec to_seq : 'a. 'a t -> 'a sequence
= fun q k -> match q with
| Shallow d -> _digit_to_seq d k
| Deep { f; m = lazy q'; r; _ } ->
_digit_to_seq f k;
to_seq q' (fun (x, y) -> k x; k y);
_digit_to_seq r k
let iter f q = to_seq q f
let _fold_digit f acc d = match d with
| Zero -> acc
| One x -> f acc x
| Two (x, y) -> f (f acc x) y
| Three (x, y, z) -> f (f (f acc x) y) z
let rec fold : 'a 'b. ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
= fun func acc q -> match q with
| Shallow d -> _fold_digit func acc d
| Deep { f; m = lazy q'; r; _ } ->
let acc = _fold_digit func acc f in
let acc = fold (fun acc (x, y) -> func (func acc x) y) acc q' in
_fold_digit func acc r
let to_list q =
let l = ref [] in
to_seq q (fun x -> l := x :: !l);
List.rev !l
let of_list l =
List.fold_left push empty l
let pp ppv ppf q =
Fmt.pf ppf "[ %a ]"
(Fmt.hvbox (Fmt.list ~sep:(Fmt.unit ";@ ") ppv)) (to_list q)