1;;; 2;;; SRFI-116 Immutable List Library 3;;; 4 5;; Gauche supports immutable pairs natively. They work transparently 6;; as mutable pairs, except set-car! and set-cdr!. 7;; Procedures that don't cons are just alias of builtin procedures. 8;; Whenever a procedure need to cons, we make an ipair instead of an mpair. 9 10;; Note that we won't reject mpair passed to these procedures. 11 12(define-module srfi-116 13 (use srfi-1) 14 (use srfi-114 :only (make-car-comparator 15 make-cdr-comparator 16 make-improper-list-comparator)) 17 (use util.match) 18 (export ipair ;builtin 19 ilist ;builtin 20 xipair ipair* make-ilist ilist-tabulate 21 ilist-copy iiota 22 23 iq 24 25 ipair? ;builtin 26 ;; NB: Other predicates don't distinguish mutable and immutable 27 ;; pairs. 28 (rename proper-list? proper-ilist?) 29 (rename list? ilist?) 30 (rename dotted-list? dotted-ilist?) 31 (rename not-pair? not-ipair?) 32 (rename null-list? null-ilist?) 33 (rename list= ilist=) 34 35 (rename car icar) (rename cdr icdr) 36 (rename caar icaar) (rename cadr icadr) 37 (rename cdar icdar) (rename cddr icddr) 38 (rename caaar icaaar) (rename caadr icaadr) 39 (rename cadar icadar) (rename caddr icaddr) 40 (rename cdaar icdaar) (rename cdadr icdadr) 41 (rename cddar icddar) (rename cdddr icdddr) 42 (rename caaaar icaaaar) (rename caaadr icaaadr) 43 (rename caadar icaadar) (rename caaddr icaaddr) 44 (rename cadaar icadaar) (rename cadadr icadadr) 45 (rename caddar icaddar) (rename cadddr icadddr) 46 (rename cdaaar icdaaar) (rename cdaadr icdaadr) 47 (rename cdadar icdadar) (rename cdaddr icdaddr) 48 (rename cddaar icddaar) (rename cddadr icddadr) 49 (rename cdddar icdddar) (rename cddddr icddddr) 50 (rename car+cdr icar+icdr) 51 (rename list-ref ilist-ref) 52 53 (rename first ifirst) (rename second isecond) 54 (rename third ithird) 55 (rename fourth ifourth) 56 (rename fifth ififth) 57 (rename sixth isixth) 58 (rename seventh iseventh) 59 (rename eighth ieighth) 60 (rename ninth ininth) 61 (rename tenth itenth) 62 itake 63 (rename drop idrop) 64 (rename list-tail ilist-tail) 65 (rename take-right itake-right) 66 idrop-right 67 isplit-at 68 (rename last ilast) 69 (rename last-pair last-ipair) 70 71 (rename length ilength) 72 iappend 73 iconcatenate 74 ireverse 75 iappend-reverse 76 izip 77 iunzip1 78 iunzip2 79 iunzip3 80 iunzip4 81 iunzip5 82 (rename count icount) 83 84 imap 85 (rename for-each ifor-each) 86 (rename fold ifold) 87 iunfold 88 (rename pair-fold ipair-fold) 89 (rename reduce ireduce) 90 (rename fold-right ifold-right) 91 iunfold-right 92 (rename pair-fold-right ipair-fold-right) 93 (rename reduce-right ireduce-right) 94 iappend-map 95 (rename pair-for-each ipair-for-each) 96 ifilter-map 97 imap-in-order 98 99 ifilter 100 ipartition 101 iremove 102 103 (rename member imember) 104 (rename memq imemq) 105 (rename memv imemv) 106 ifind 107 (rename find-tail ifind-tail) 108 (rename any iany) 109 (rename every ievery) 110 (rename list-index ilist-index) 111 itake-while 112 (rename drop-while idrop-while) 113 ispan 114 ibreak 115 116 idelete 117 idelete-duplicates 118 119 (rename assoc iassoc) 120 (rename assq iassq) 121 (rename assv iassv) 122 ialist-cons 123 ialist-delete 124 125 replace-icar 126 replace-icdr 127 128 pair->ipair 129 ipair->pair 130 list->ilist 131 ilist->list 132 tree->itree 133 itree->tree 134 gtree->itree 135 gtree->tree 136 137 (rename apply iapply) 138 139 ipair-comparator 140 ilist-comparator 141 (rename make-list-comparator make-ilist-comparator) 142 (rename make-improper-list-comparator make-improper-ilist-comparator) 143 (rename make-car-comparator make-icar-comparator) 144 (rename make-cdr-comparator make-icdr-comparator) 145 )) 146(select-module srfi-116) 147 148(define-syntax iq 149 (syntax-rules () 150 [(iq x ...) 151 (gtree->itree '(x ...))])) 152 153(define (xipair cd ca) (ipair ca cd)) 154(define (ipair* x . xs) 155 (if (null? xs) 156 x 157 (ipair x (apply ipair* xs)))) 158(define (make-ilist n :optional (fill (undefined))) 159 (let loop ([r '()] [n n]) 160 (if (<= n 0) 161 r 162 (loop (ipair fill r) (- n 1))))) 163(define (ilist-tabulate n init-proc) 164 (let loop ([r '()] [n (- n 1)]) 165 (if (< n 0) 166 r 167 (loop (ipair (init-proc n) r) (- n 1))))) 168(define (ilist-copy lis) 169 (fold ipair '() (reverse lis))) 170 171;; Almost identical code of iota in src/liblist.scm, but using ipair instead 172;; of cons. 173(define (iiota count :optional (start 0) (step 1)) 174 (unless (and (integer? count) (>= count 0)) 175 (error "count must be nonnegative integer: " count)) 176 (if (and (exact? start) (exact? step)) 177 ;; we allow inexact integer as 'count', for the consistency of 178 ;; giota and liota in which we can also accept +inf.0 as count. 179 (let1 count (exact count) 180 (do ([c count (- c 1)] 181 [v (+ start (* (- count 1) step)) (- v step)] 182 [r '() (ipair v r)]) 183 [(<= c 0) r])) 184 ;; for inexact numbers, we use multiplication to avoid error accumulation. 185 (do ([c count (- c 1)] 186 [r '() (ipair (+ start (*. (- c 1) step)) r)]) 187 [(<= c 0) r]))) 188 189(define (itake lis i) 190 (assume exact-integer? i) 191 (if (<= i 0) 192 '() 193 (ipair (car lis) (itake (cdr lis) (- i 1))))) 194(define (idrop-right lis i) 195 (assume exact-integer? i) 196 (let rec ([p0 (list-tail lis i)] [p1 lis]) 197 (if (pair? p0) (ipair (car p1) (rec (cdr p0) (cdr p1))) '()))) 198(define (isplit-at lis i) 199 (assume exact-integer? i) 200 (let rec ([lis lis] [i i]) 201 (if (<= i 0) 202 (values '() lis) 203 (receive (hd tl) (rec (cdr lis) (- i 1)) 204 (values (ipair (car lis) hd) tl))))) 205 206(define (iappend . liss) (iconcatenate liss)) 207 208(define (iconcatenate liss) 209 (match liss 210 ([] '()) 211 ([lis] lis) 212 ([lis1 . liss] 213 (let1 tail (iconcatenate liss) 214 (let rec ([lis1 lis1]) 215 (if (null? lis1) 216 tail 217 (ipair (car lis1) (rec (cdr lis1))))))))) 218 219(define (ireverse lis) (fold ipair '() lis)) 220 221(define (iappend-reverse rev-head tail) (fold ipair tail rev-head)) 222 223(define (izip lis1 . liss) (apply imap ilist lis1 liss)) 224 225;; These are dupe of srfi-1.scm except map/cons replaced with imap/ipair 226(define (iunzip1 lis) (imap car lis)) 227 228(define (iunzip2 lis) 229 (let recur ((lis lis)) 230 (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle 231 (let ((elt (car lis))) ; dotted lists. 232 (receive (a b) (recur (cdr lis)) 233 (values (ipair (car elt) a) 234 (ipair (cadr elt) b))))))) 235 236(define (iunzip3 lis) 237 (let recur ((lis lis)) 238 (if (null-list? lis) (values lis lis lis) 239 (let ((elt (car lis))) 240 (receive (a b c) (recur (cdr lis)) 241 (values (ipair (car elt) a) 242 (ipair (cadr elt) b) 243 (ipair (caddr elt) c))))))) 244 245(define (iunzip4 lis) 246 (let recur ((lis lis)) 247 (if (null-list? lis) (values lis lis lis lis) 248 (let ((elt (car lis))) 249 (receive (a b c d) (recur (cdr lis)) 250 (values (ipair (car elt) a) 251 (ipair (cadr elt) b) 252 (ipair (caddr elt) c) 253 (ipair (cadddr elt) d))))))) 254 255(define (iunzip5 lis) 256 (let recur ((lis lis)) 257 (if (null-list? lis) (values lis lis lis lis lis) 258 (let ((elt (car lis))) 259 (receive (a b c d e) (recur (cdr lis)) 260 (values (ipair (car elt) a) 261 (ipair (cadr elt) b) 262 (ipair (caddr elt) c) 263 (ipair (cadddr elt) d) 264 (ipair (car (cddddr elt)) e))))))) 265 266 267(define imap 268 (case-lambda 269 ([proc lis] (fold-right (^[x ys] (ipair (proc x) ys)) '() lis)) 270 ([proc lis . liss] 271 (ireverse (apply fold-left (^[ys . xs] (cons (apply proc xs) ys)) '() 272 lis liss))))) 273 274(define (iunfold p f g seed :optional (tail-gen (^_ '()))) 275 (let rec ((seed seed)) 276 (if (p seed) 277 (tail-gen seed) 278 (ipair (f seed) (rec (g seed)))))) 279 280(define (iunfold-right p f g seed :optional (ans '())) 281 (let loop ((seed seed) (ans ans)) 282 (if (p seed) 283 ans 284 (loop (g seed) 285 (ipair (f seed) ans))))) 286 287(define (iappend-map proc lis . lists) 288 (iconcatenate (apply map proc lis lists))) 289 290(define (ifilter-map proc lis . lists) 291 (if (null? lists) 292 (let loop ([lis lis] [r '()]) 293 (cond [(null-list? lis) (ireverse r)] 294 [(proc (car lis)) => (^x (loop (cdr lis) (cons x r)))] 295 [else (loop (cdr lis) r)])) 296 (let loop ([liss (cons lis lists)] [r '()]) 297 (receive (cars cdrs) 298 ((with-module gauche.internal %zip-nary-args) liss) 299 (cond [(not cars) (ireverse r)] 300 [(apply proc cars) => (^x (loop cdrs (cons x r)))] 301 [else (loop cdrs r)]))))) 302 303(define imap-in-order 304 (case-lambda 305 ([proc lis] (ireverse (fold (^[x ys] (cons (proc x) ys)) '() lis))) 306 ([proc lis . liss] 307 (ireverse (apply fold-left (^[ys . xs] (cons (apply proc xs) ys)) '() 308 lis liss))))) 309 310(define (ifilter pred lis) 311 (let loop ([lis lis] [r '()]) 312 (cond [(null-list? lis) (ireverse r)] 313 [(pred (car lis)) (loop (cdr lis) (cons (car lis) r))] 314 [else (loop (cdr lis) r)]))) 315 316(define (iremove pred l) (ifilter (^x (not (pred x))) l)) 317 318;;built-in find tolerate improper lists. we're bit more strict here. 319(define (ifind pred lis) 320 (cond [(null? lis) #f] 321 [(not (pair? lis)) (error "pair expected, but got:" lis)] 322 [(pred (car lis)) (car lis)] 323 [else (ifind pred (cdr lis))])) 324 325(define (ipartition pred lis) 326 (let rec ([lis lis] [xs '()] [ys '()]) 327 (if (null-list? lis) 328 (values (ireverse xs) (ireverse ys)) 329 (if (pred (car lis)) 330 (rec (cdr lis) (cons (car lis) xs) ys) 331 (rec (cdr lis) xs (cons (car lis) ys)))))) 332 333(define (itake-while pred lis) 334 (cond [(null? lis) '()] 335 [(pred (car lis)) (ipair (car lis) (itake-while pred (cdr lis)))] 336 [else '()])) 337 338(define (ispan pred lis) 339 (cond [(null? lis) '()] 340 [(pred (car lis)) 341 (receive (pre post) (ispan pred (cdr lis)) 342 (values (ipair (car lis) pre) post))] 343 [else (values '() lis)])) 344 345(define (ibreak pred lis) (ispan (complement pred) lis)) 346 347(define (idelete x lis :optional (eq equal?)) 348 (if (null? lis) 349 '() 350 (let1 tail (idelete x (cdr lis) eq) 351 (cond [(eq x (car lis)) tail] 352 [(eq? (cdr lis) tail) lis] 353 [else (ipair (car lis) tail)])))) 354 355(define (idelete-duplicates lis :optional (eq equal?)) 356 (cond [(null? lis) lis] 357 [(null? (cdr lis)) lis] 358 [else (let1 tail (idelete (car lis) 359 (idelete-duplicates (cdr lis) eq) 360 eq) 361 (if (eq? tail (cdr lis)) 362 lis 363 (ipair (car lis) tail)))])) 364 365(define (ialist-cons k d alis) 366 (ipair (ipair k d) alis)) 367 368(define (ialist-delete k alis :optional (eq equal?)) 369 (cond [(null? alis) '()] 370 [(eq k (caar alis)) (ialist-delete k (cdr alis) eq)] 371 [else (let1 tail (ialist-delete k (cdr alis) eq) 372 (if (eq? tail (cdr alis)) 373 alis 374 (ipair (car alis) tail)))])) 375 376(define (replace-icar p obj) (ipair obj (cdr p))) 377(define (replace-icdr p obj) (ipair (car p) obj)) 378 379(define (pair->ipair p) (ipair (car p) (cdr p))) 380(define (ipair->pair p) (cons (car p) (cdr p))) 381 382(define (list->ilist p) 383 (cond [(null? p) '()] 384 [(ipair? p) (let1 tail (list->ilist (cdr p)) 385 (if (eq? (cdr p) tail) 386 p 387 (ipair (car p) tail)))] 388 [(pair? p) (ipair (car p) (list->ilist (cdr p)))] 389 [else p])) 390(define (ilist->list p) 391 (cond [(null? p) '()] 392 [(pair? p) (let1 tail (ilist->list (cdr p)) 393 (if (eq? (cdr p) tail) 394 p 395 (cons (car p) tail)))] 396 [(ipair? p) (cons (car p) (ilist->list (cdr p)))] 397 [else p])) 398 399(define (tree->itree p) 400 (cond [(ipair? p) 401 (let ([ca (tree->itree (car p))] 402 [cd (tree->itree (cdr p))]) 403 (if (and (eq? ca (car p)) (eq? cd (cdr p))) 404 p 405 (ipair ca cd)))] 406 [(pair? p) 407 (ipair (tree->itree (car p)) (tree->itree (cdr p)))] 408 [else p])) 409(define (itree->tree p) 410 (cond [(pair? p) 411 (let ([ca (itree->tree (car p))] 412 [cd (itree->tree (cdr p))]) 413 (if (and (eq? ca (car p)) (eq? cd (cdr p))) 414 p 415 (cons ca cd)))] 416 [(ipair? p) 417 (cons (itree->tree (car p)) (itree->tree (cdr p)))] 418 [else p])) 419 420;; Our itree->tree and tree->itree accepts mixed trees, so these are the same. 421(define (gtree->itree obj) (tree->itree obj)) 422(define (gtree->tree obj) (itree->tree obj)) 423 424 425(define ipair-comparator 426 (make-comparator/compare ipair? #t compare default-hash 'ipair-comparator)) 427(define ilist-comparator 428 (make-comparator/compare list? #t compare default-hash 'ilist-comparator)) 429