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