1;;;
2;;; srfi-101 - Purely Functional Random-Access Pairs and Lists
3;;;
4;;;   Copyright (c) 2019-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34(define-module srfi-101
35  (use gauche.record)
36  (use gauche.sequence)
37  (use util.match)
38  (use data.skew-list)
39  (export (rename ra-quote quote)
40          (rename ra-pair? pair?)
41          (rename ra-cons cons)
42          (rename ra-car car)
43          (rename ra-cdr cdr)
44          (rename ra-caar caar)
45          (rename ra-cadr cadr)
46          (rename ra-cddr cddr)
47          (rename ra-cdar cdar)
48          (rename ra-caaar caaar)
49          (rename ra-caadr caadr)
50          (rename ra-caddr caddr)
51          (rename ra-cadar cadar)
52          (rename ra-cdaar cdaar)
53          (rename ra-cdadr cdadr)
54          (rename ra-cdddr cdddr)
55          (rename ra-cddar cddar)
56          (rename ra-caaaar caaaar)
57          (rename ra-caaadr caaadr)
58          (rename ra-caaddr caaddr)
59          (rename ra-caadar caadar)
60          (rename ra-cadaar cadaar)
61          (rename ra-cadadr cadadr)
62          (rename ra-cadddr cadddr)
63          (rename ra-caddar caddar)
64          (rename ra-cdaaar cdaaar)
65          (rename ra-cdaadr cdaadr)
66          (rename ra-cdaddr cdaddr)
67          (rename ra-cdadar cdadar)
68          (rename ra-cddaar cddaar)
69          (rename ra-cddadr cddadr)
70          (rename ra-cddddr cddddr)
71          (rename ra-cdddar cdddar)
72          (rename ra-null? null?)
73          (rename ra-list? list?)
74          (rename ra-list list)
75          (rename ra-make-list make-list)
76          (rename ra-length length)
77          (rename ra-append append)
78          (rename ra-reverse reverse)
79          (rename ra-list-tail list-tail)
80          (rename ra-list-ref list-ref)
81          (rename ra-list-set list-set)
82          (rename ra-list-ref/update list-ref/update)
83          (rename ra-map map)
84          (rename ra-for-each for-each)
85          (rename ra-random-access-list->linear-access-list
86                  random-access-list->linear-access-list)
87          (rename ra-linear-access-list->random-access-list
88                  linear-access-list->random-access-list)
89          equal?                        ; builtin equal? works
90          ))
91
92(select-module srfi-101)
93
94;; We base on data.skew-list, but we need to extend it to support
95;; improper lists.  We just keep the last cdr separately.
96
97(define-record-type <ra-list>
98  %make-ra ra-pair?
99  (spine ra-spine)                      ; <skew-list>
100  (last-cdr ra-last-cdr))               ; The last cdr
101
102(define (make-ra spine last-cdr)
103  (if (skew-list-empty? spine)
104    last-cdr
105    (%make-ra spine last-cdr)))
106
107;; This is not in srfi-101, but for the convenience
108(define-method write-object ((x <ra-list>) port)
109  (display "#,(rlist (" port)
110  (skew-list-fold (ra-spine x)
111                  (^[e c]
112                    (unless (zero? c) (display " " port))
113                    (write e port)
114                    (+ c 1))
115                  0)
116  (unless (null? (ra-last-cdr x))
117    (display " . " port)
118    (write (ra-last-cdr x) port))
119  (display "))" port))
120
121(define-reader-ctor 'rlist
122  (^x (ra-linear-access-list->random-access-list x)))
123
124;; internal
125(define (ra-proper? obj)
126  (and (ra-pair? obj) (null? (ra-last-cdr obj))))
127
128;; Primitives
129(define-syntax ra-quote
130  (er-macro-transformer
131   (^[f r c]
132     (define (%x->ra obj)
133       (if (pair? obj)
134         (ra-cons (%x->ra (car obj)) (%x->ra (cdr obj)))
135         obj))
136     (match f
137       [(_ x) (quasirename r
138                `(quote ,(%x->ra x)))]
139       [_ (error "Malformed random-access list quote:" f)]))))
140
141(define (ra-null? x) (null? x))
142(define (ra-list? x) (or (null? x) (ra-proper? x)))
143
144(define (ra-cons x y)
145  (if (ra-pair? y)
146    (make-ra (skew-list-cons x (ra-spine y)) (ra-last-cdr y))
147    (make-ra (skew-list-cons x skew-list-null) y)))
148
149(define (ra-car obj)
150  (if (ra-pair? obj)
151    (skew-list-car (ra-spine obj))
152    (error "Attempt to take ra-car of " obj)))
153
154(define (ra-cdr obj)
155  (if (ra-pair? obj)
156    (make-ra (skew-list-cdr (ra-spine obj)) (ra-last-cdr obj))
157    (error "Attempt to take ra-cdr of " obj)))
158
159(define (%ra-ref obj n)
160  (assume-type obj <ra-list>)
161  (skew-list-ref (ra-spine obj) n))
162(define (%ra-drop obj n)
163  (assume-type obj <ra-list>)
164  (let1 spine (skew-list-drop (ra-spine obj) n)
165    (make-ra spine (ra-last-cdr obj))))
166
167
168(define (ra-caar obj) (ra-car (ra-car obj)))
169(define (ra-cadr obj) (%ra-ref obj 1))
170(define (ra-cdar obj) (ra-cdr (ra-car obj)))
171(define (ra-cddr obj) (%ra-drop obj 2))
172
173(define (ra-caaar obj) (ra-car (ra-caar obj)))
174(define (ra-caadr obj) (ra-car (ra-cadr obj)))
175(define (ra-cadar obj) (ra-car (ra-cdar obj)))
176(define (ra-caddr obj) (%ra-ref obj 2))
177(define (ra-cdaar obj) (ra-cdr (ra-caar obj)))
178(define (ra-cdadr obj) (ra-cdr (ra-cadr obj)))
179(define (ra-cddar obj) (ra-cdr (ra-cdar obj)))
180(define (ra-cdddr obj) (%ra-drop obj 3))
181
182(define (ra-caaaar obj) (ra-car (ra-caaar obj)))
183(define (ra-caaadr obj) (ra-car (ra-caadr obj)))
184(define (ra-caadar obj) (ra-car (ra-cadar obj)))
185(define (ra-caaddr obj) (ra-car (ra-caddr obj)))
186(define (ra-cadaar obj) (ra-car (ra-cdaar obj)))
187(define (ra-cadadr obj) (ra-car (ra-cdadr obj)))
188(define (ra-caddar obj) (ra-car (ra-cddar obj)))
189(define (ra-cadddr obj) (%ra-ref obj 3))
190(define (ra-cdaaar obj) (ra-cdr (ra-caaar obj)))
191(define (ra-cdaadr obj) (ra-cdr (ra-caadr obj)))
192(define (ra-cdadar obj) (ra-cdr (ra-cadar obj)))
193(define (ra-cdaddr obj) (ra-cdr (ra-caddr obj)))
194(define (ra-cddaar obj) (ra-cdr (ra-cdaar obj)))
195(define (ra-cddadr obj) (ra-cdr (ra-cdadr obj)))
196(define (ra-cdddar obj) (ra-cdr (ra-cddar obj)))
197(define (ra-cddddr obj) (%ra-drop obj 4))
198
199(define (ra-list . elts) (ra-linear-access-list->random-access-list elts))
200(define (ra-make-list n :optional obj)
201  (ra-linear-access-list->random-access-list (make-list n obj)))
202
203(define (ra-length ra)
204  (cond [(ra-null? ra) 0]
205        [(ra-proper? ra) (skew-list-length (ra-spine ra))]
206        [else
207         (error "Attempt to take length of improper random-access-list:" ra)]))
208
209(define (ra-length<=? ra k)
210  (if (ra-pair? ra)
211    (skew-list-length<=? (ra-spine ra) k)
212    (zero? k)))
213
214(define-method object-equal? ((ra1 <ra-list>) (ra2 <ra-list>))
215  (and (equal? (ra-last-cdr ra1) (ra-last-cdr ra2))
216       (equal? (ra-spine ra1) (ra-spine ra2))))
217
218(define (ra-append obj . objs)
219  (cond [(null? objs) obj]
220        [(null? obj) (apply ra-append objs)]
221        [(ra-proper? obj)
222         (let1 tail (apply ra-append objs)
223           (if (ra-pair? tail)
224             (make-ra (skew-list-append (ra-spine obj)
225                                        (ra-spine tail))
226                      (ra-last-cdr tail))
227             (make-ra (ra-spine obj) tail)))]
228        [else
229         (error "Can't append an improper random-access list:" obj)]))
230
231(define (ra-reverse ra)
232  (cond [(ra-null? ra) ra]
233        [(ra-proper? ra)
234         (make-ra (list->skew-list (reverse (skew-list->lseq (ra-spine ra))))
235                  '())]
236        [else (error "Can't reverse an improper random-access list:" ra)]))
237
238(define (ra-list-tail obj k)
239  (cond [(zero? k) obj]
240        [(ra-pair? obj)
241         (make-ra (skew-list-drop (ra-spine obj) k)
242                  (ra-last-cdr obj))]
243        [else (error "Index out of range:" k)]))
244
245(define (ra-list-ref ra k)
246  (assume (ra-pair? ra))
247  (skew-list-ref (ra-spine ra) k))
248
249(define (ra-list-set ra k elt)
250  (assume (ra-pair? ra))
251  (make-ra (skew-list-set (ra-spine ra) k elt)
252           (ra-last-cdr ra)))
253
254(define (ra-list-ref/update ra k proc)
255  (assume (ra-pair? ra))
256  (let1 v (ra-list-ref ra k)
257    (values v (ra-list-set ra k (proc v)))))
258
259(define ra-map
260  (case-lambda
261    [(proc ra)
262     ;; fast path
263     (assume (ra-proper? ra))
264     (make-ra (skew-list-map (ra-spine ra) proc) '())]
265    [(proc) (error "At least one random-access list argument required.")]
266    [(proc . ras)
267     (assume (every ra-proper? ras))
268     (assume (apply = (map ra-length ras)))
269     (make-ra (apply map-to <skew-list> proc (map ra-spine ras)) '())]))
270
271(define ra-for-each
272  (case-lambda
273    [(proc ra)
274     (assume (ra-proper? ra))
275     (skew-list-fold (ra-spine ra) (^[elt _] (proc elt)) #f)
276     (undefined)]
277    [(proc) (error "At least one random-access list argument required.")]
278    [(proc . ras)
279     (assume (every ra-proper? ras))
280     (assume (apply = (map ra-length ras)))
281     (apply for-each proc (map ra-spine ras))]))
282
283(define (ra-random-access-list->linear-access-list ra)
284  (assume (ra-list? ra))
285  (if (null? ra)
286    ra
287    (skew-list->list (ra-spine ra))))
288
289(define (ra-linear-access-list->random-access-list lis)
290  (assume (proper-list? lis))
291  (make-ra (list->skew-list lis) '()))
292