1#| doc
2Random access lists are a data structure similar to lists,
3but with very different efficiency characteristics.
4A regular list built out of cons cells is an optimal solution,
5   if one needs to work mainly with the initial elements or the whole list at a time.
6However, if you need to frequently find and maybe update values in the middle of the list,
7   you have to perform operations taking time proportional to the length of the list.
8In other words, those list operations are linear time, or have complexity O(n).
9Cons, car and cdr on the other hand are very efficient for regular lists.
10Regardless of the size of a list, it will always take a fixed amount of time to add, take or remove a value from it.
11In other words, these operations are constant time, or have complexity O(1).
12
13A random access list is a data structure,
14   which unsurprisingly attempts to make random access and update efficient.
15
16The performance characteristics of this random access list library are:
17```
18  car → O(1)
19  cdr → O(log n)
20  cons → O(log n)
21  get → O(log n)
22  set → O(log n)
23  len → O(log n)
24  fold → O(n)
25  append → O(n)
26  list->rlist → O(n log n)
27  rlist->list → O(n)
28```
29
30The operation is based on two ideas.
31Firstly, a random access list consists of a sequence of complete binary trees.
32The binary trees are built out of cons cells when needed.
33The first tree is always of height 1, meaning it just holds the value, much like a regular cons cell.
34The next node always holds a binary tree either of the same or next height.
35There can be at most two trees of the same height next to eachother.
36Therefore, tree heights `(1 1)`, `(1 2 4)` and `(1 1 2 4 4)` are valid,
37   whereas `(1 1 1)`, `(2 2 4)` and `(1 2 2 8)` are not.
38`(5)` is right out.
39
40Secondly, trees can be addressed directly with bits.
41It takes a n-bit number address each node of a complete binary tree of height n.
42Finding a value from a list works by first finding the tree in which the value is held,
43  and then using the remaining bits to find the correct leaf node in the tree.
44
45It is easy to see that it takes O(log n) steps to find the tree in which some particular value is held,
46   and then another O(log n) steps to walk the tree to a given position,
47Threfore we have a total complexity of O(log n) for access and update.
48
49```
50  (rcar (rcons 11 rnull)) → 11
51  (rnull? (rcons 11 rnull)) → #false
52  (rlist->list (rcons 1 (rcons 2 rnull))) → (1 2))
53  (rget (list->rlist (iota 0 1 1000)) 123 #f) → 123
54  (rget (list->rlist (iota 0 1 1000)) 1234 #f) → #false
55```
56
57|#
58
59(define-library (owl lcd rlist)
60
61   (import
62      (owl core)
63      (only (owl syscall) error)
64      (owl sum)
65      (owl list))
66
67   (export
68      rnull
69      rcons
70      rget
71      rcar
72      rcdr
73      rset
74      rlen
75      rlist
76      rfold
77      rfoldr
78      riter
79      riterr
80      rmap
81      rnull?
82      rpair?
83      list->rlist
84      rlist->list)
85
86   (begin
87
88      ;; note that for now the pattern match must come in the same order
89      ;; as the data type definition
90      (define-sum-type rl-case
91         (snd x t)
92         (fst x t)
93         (nil))
94
95      (define rnull (nil))
96
97      (define (nope op)
98         (error "invalid rlist arguments to " op))
99
100      (define (rcons x as)
101         (rl-case as
102            ((snd a bs) (nope 'rcons))
103            ((fst a bs)
104               (rl-case bs
105                  ((snd b cs)
106                     (rl-case cs
107                        ((snd v d) (nope 'rcons))
108                        ((fst v d)
109                           (fst x (rcons (cons a b) cs)))
110                        ((nil) (fst x (fst (cons a b) rnull)))))
111                  ((fst b cs) (fst x (snd a bs)))
112                  ((nil) (fst x (snd a rnull)))))
113            ((nil) (fst x rnull))))
114
115      (define (rcar rl . def)
116         (rl-case rl
117            ((snd a bs) (error 'rcar rl))
118            ((fst a bs) a)
119            ((nil)
120               (if (null? def)
121                  (error 'rcar 'null)
122                  (car def)))))
123
124      (define (tof) #f)
125
126      (define rnull?
127         (let ((y (λ () #t))
128               (n (λ (a b) #f)))
129            (λ (rl) (rl n n y))))
130
131      (define rpair?
132         (let ((y (λ (a b) #t))
133               (n (λ () #f)))
134            (λ (rl) (rl y y n))))
135
136      (define (drop as)
137         (rl-case as
138            ((snd a bs)
139               (fst a bs))
140            ((fst ab cs)
141               (fst (car ab)
142                  (snd (cdr ab)
143                     (drop cs))))
144            ((nil)
145               rnull)))
146
147      (define (rcdr as)
148         (rl-case as
149            ((snd a as) (nope 'rcdr))
150            ((fst a as) (drop as))
151            ((nil) rnull)))
152
153      (define (pick tree path depth)
154         (if (eq? depth 1)
155            tree
156            (lets ((depth _ (fx>> depth 1)))
157               (if (eq? (fxand path depth) 0)
158                  (pick (car tree) path depth)
159                  (pick (cdr tree) path depth)))))
160
161      (define (rlen rl)
162         (let loop ((rl rl) (d 0) (dp 1) (n 0))
163            (rl-case rl
164               ((snd tree rl)
165                  (lets ((n _ (fx+ n d)))
166                     (loop rl d dp n)))
167               ((fst tree rl)
168                  (lets
169                     ((d dp)
170                      (dp _ (fx+ dp dp))
171                      (n _ (fx+ n d)))
172                     (loop rl d dp n)))
173               ((nil) n))))
174
175      (define (rget rl pos def)
176         (let loop ((rl rl) (d 0) (dp 1) (pos pos))
177            (rl-case rl
178               ((snd tree rl)
179                  (lets ((posp u (fx- pos d)))
180                     (if (eq? u 0)
181                        (loop rl d dp posp)
182                        (pick tree pos d))))
183               ((fst tree rl)
184                  (lets
185                     ((d dp)
186                      (dp _ (fx+ dp dp))
187                      (posp u (fx- pos d)))
188                     (if (eq? u 0)
189                        (loop rl d dp posp)
190                        (pick tree pos d))))
191               ((nil) def))))
192
193      ;; rset is rget + path copying
194
195      (define (set tree path depth val)
196         (if (eq? depth 1)
197            val
198            (lets ((depth _ (fx>> depth 1)))
199               (if (eq? (fxand path depth) 0)
200                  (cons (set (car tree) path depth val) (cdr tree))
201                  (cons (car tree) (set (cdr tree) path depth val))))))
202
203      (define (rset rl pos val)
204         (let loop ((rl rl) (d 0) (dp 1) (pos pos))
205            (rl-case rl
206               ((snd tree rl)
207                  (lets ((posp u (fx- pos d)))
208                     (if (eq? u 0)
209                        (snd tree (loop rl d dp posp))
210                        (snd (set tree pos d val) rl))))
211               ((fst tree rl)
212                  (lets
213                     ((d dp)
214                      (dp _ (fx+ dp dp))
215                      (posp u (fx- pos d)))
216                     (if (eq? u 0)
217                        (fst tree (loop rl d dp posp))
218                        (fst (set tree pos d val) rl))))
219               ((nil) rl))))
220
221      ;;; fold from left
222
223      (define (rfold-node op st n d)
224         (if (eq? d 1)
225            (op st n)
226            (lets ((d _ (fx>> d 1)))
227               (rfold-node op (rfold-node op st (car n) d) (cdr n) d))))
228
229      (define (rfold op st rl)
230         (let loop ((rl rl) (st st) (depth 0))
231            (rl-case rl
232               ((snd a rl)
233                  (loop rl (rfold-node op st a depth) depth))
234               ((fst a rl)
235                  (if (eq? depth 0)
236                     (loop rl (op st a) 1)
237                     (lets ((depth _ (fx+ depth depth)))
238                        (loop rl
239                           (rfold-node op st a depth)
240                           depth))))
241               ((nil) st))))
242
243      (define (list->rlist x)
244         (foldr rcons rnull x))
245
246      (define (rlist->list rl)
247         (reverse (rfold (λ (pre val) (cons val pre)) '() rl)))
248
249      (define (rlist . args)
250         (list->rlist args))
251
252      (define rmap    #f)
253      (define rfoldr  #f)
254      (define riter   #f)
255      (define riterr  #f)
256
257))
258