| 1 |
;;; SRFI-1 list-processing library -*- Scheme -*- |
| 2 |
;;; Reference implementation |
| 3 |
;;; |
| 4 |
;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with |
| 5 |
;;; this code as long as you do not remove this copyright notice or |
| 6 |
;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. |
| 7 |
;;; -Olin |
| 8 |
|
| 9 |
;;; This is a library of list- and pair-processing functions. I wrote it after |
| 10 |
;;; carefully considering the functions provided by the libraries found in |
| 11 |
;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common |
| 12 |
;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty |
| 13 |
;;; rich toolkit, providing a superset of the functionality found in any of |
| 14 |
;;; the various Schemes I considered. |
| 15 |
|
| 16 |
;;; This implementation is intended as a portable reference implementation |
| 17 |
;;; for SRFI-1. See the porting notes below for more information. |
| 18 |
|
| 19 |
;;; Exported: |
| 20 |
;;; xcons tree-copy make-list list-tabulate cons* list-copy |
| 21 |
;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= |
| 22 |
;;; circular-list length+ |
| 23 |
;;; iota |
| 24 |
;;; first second third fourth fifth sixth seventh eighth ninth tenth |
| 25 |
;;; car+cdr |
| 26 |
;;; take drop |
| 27 |
;;; take-right drop-right |
| 28 |
;;; take! drop-right! |
| 29 |
;;; split-at split-at! |
| 30 |
;;; last last-pair |
| 31 |
;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 |
| 32 |
;;; count |
| 33 |
;;; append! append-reverse append-reverse! concatenate concatenate! |
| 34 |
;;; unfold fold pair-fold reduce |
| 35 |
;;; unfold-right fold-right pair-fold-right reduce-right |
| 36 |
;;; append-map append-map! map! pair-for-each filter-map map-in-order |
| 37 |
;;; filter partition remove |
| 38 |
;;; filter! partition! remove! |
| 39 |
;;; find find-tail any every list-index |
| 40 |
;;; take-while drop-while take-while! |
| 41 |
;;; span break span! break! |
| 42 |
;;; delete delete! |
| 43 |
;;; alist-cons alist-copy |
| 44 |
;;; delete-duplicates delete-duplicates! |
| 45 |
;;; alist-delete alist-delete! |
| 46 |
;;; reverse! |
| 47 |
;;; lset<= lset= lset-adjoin |
| 48 |
;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection |
| 49 |
;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! |
| 50 |
;;; |
| 51 |
;;; In principle, the following R4RS list- and pair-processing procedures |
| 52 |
;;; are also part of this package's exports, although they are not defined |
| 53 |
;;; in this file: |
| 54 |
;;; Primitives: cons pair? null? car cdr set-car! set-cdr! |
| 55 |
;;; Non-primitives: list length append reverse cadr ... cddddr list-ref |
| 56 |
;;; memq memv assq assv |
| 57 |
;;; (The non-primitives are defined in this file, but commented out.) |
| 58 |
;;; |
| 59 |
;;; These R4RS procedures have extended definitions in SRFI-1 and are defined |
| 60 |
;;; in this file: |
| 61 |
;;; map for-each member assoc |
| 62 |
;;; |
| 63 |
;;; The remaining two R4RS list-processing procedures are not included: |
| 64 |
;;; list-tail (use drop) |
| 65 |
;;; list? (use proper-list?) |
| 66 |
|
| 67 |
|
| 68 |
;;; A note on recursion and iteration/reversal: |
| 69 |
;;; Many iterative list-processing algorithms naturally compute the elements |
| 70 |
;;; of the answer list in the wrong order (left-to-right or head-to-tail) from |
| 71 |
;;; the order needed to cons them into the proper answer (right-to-left, or |
| 72 |
;;; tail-then-head). One style or idiom of programming these algorithms, then, |
| 73 |
;;; loops, consing up the elements in reverse order, then destructively |
| 74 |
;;; reverses the list at the end of the loop. I do not do this. The natural |
| 75 |
;;; and efficient way to code these algorithms is recursively. This trades off |
| 76 |
;;; intermediate temporary list structure for intermediate temporary stack |
| 77 |
;;; structure. In a stack-based system, this improves cache locality and |
| 78 |
;;; lightens the load on the GC system. Don't stand on your head to iterate! |
| 79 |
;;; Recurse, where natural. Multiple-value returns make this even more |
| 80 |
;;; convenient, when the recursion/iteration has multiple state values. |
| 81 |
|
| 82 |
;;; Porting: |
| 83 |
;;; This is carefully tuned code; do not modify casually. |
| 84 |
;;; - It is careful to share storage when possible; |
| 85 |
;;; - Side-effecting code tries not to perform redundant writes. |
| 86 |
;;; |
| 87 |
;;; That said, a port of this library to a specific Scheme system might wish |
| 88 |
;;; to tune this code to exploit particulars of the implementation. |
| 89 |
;;; The single most important compiler-specific optimisation you could make |
| 90 |
;;; to this library would be to add rewrite rules or transforms to: |
| 91 |
;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, |
| 92 |
;;; LSET-UNION) into multiple applications of a primitive two-argument |
| 93 |
;;; variant. |
| 94 |
;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, |
| 95 |
;;; ANY, EVERY) into open-coded loops. The killer here is that these |
| 96 |
;;; functions are n-ary. Handling the general case is quite inefficient, |
| 97 |
;;; requiring many intermediate data structures to be allocated and |
| 98 |
;;; discarded. |
| 99 |
;;; - transform applications of procedures that take optional arguments |
| 100 |
;;; into calls to variants that do not take optional arguments. This |
| 101 |
;;; eliminates unnecessary consing and parsing of the rest parameter. |
| 102 |
;;; |
| 103 |
;;; These transforms would provide BIG speedups. In particular, the n-ary |
| 104 |
;;; mapping functions are particularly slow and cons-intensive, and are good |
| 105 |
;;; candidates for tuning. I have coded fast paths for the single-list cases, |
| 106 |
;;; but what you really want to do is exploit the fact that the compiler |
| 107 |
;;; usually knows how many arguments are being passed to a particular |
| 108 |
;;; application of these functions -- they are usually explicitly called, not |
| 109 |
;;; passed around as higher-order values. If you can arrange to have your |
| 110 |
;;; compiler produce custom code or custom linkages based on the number of |
| 111 |
;;; arguments in the call, you can speed these functions up a *lot*. But this |
| 112 |
;;; kind of compiler technology no longer exists in the Scheme world as far as |
| 113 |
;;; I can see. |
| 114 |
;;; |
| 115 |
;;; Note that this code is, of course, dependent upon standard bindings for |
| 116 |
;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound |
| 117 |
;;; to the procedure that takes the car of a list. If your Scheme |
| 118 |
;;; implementation allows user code to alter the bindings of these procedures |
| 119 |
;;; in a manner that would be visible to these definitions, then there might |
| 120 |
;;; be trouble. You could consider horrible kludgery along the lines of |
| 121 |
;;; (define fact |
| 122 |
;;; (let ((= =) (- -) (* *)) |
| 123 |
;;; (letrec ((real-fact (lambda (n) |
| 124 |
;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) |
| 125 |
;;; real-fact))) |
| 126 |
;;; Or you could consider shifting to a reasonable Scheme system that, say, |
| 127 |
;;; has a module system protecting code from this kind of lossage. |
| 128 |
;;; |
| 129 |
;;; This code does a fair amount of run-time argument checking. If your |
| 130 |
;;; Scheme system has a sophisticated compiler that can eliminate redundant |
| 131 |
;;; error checks, this is no problem. However, if not, these checks incur |
| 132 |
;;; some performance overhead -- and, in a safe Scheme implementation, they |
| 133 |
;;; are in some sense redundant: if we don't check to see that the PROC |
| 134 |
;;; parameter is a procedure, we'll find out anyway three lines later when |
| 135 |
;;; we try to call the value. It's pretty easy to rip all this argument |
| 136 |
;;; checking code out if it's inappropriate for your implementation -- just |
| 137 |
;;; nuke every call to CHECK-ARG. |
| 138 |
;;; |
| 139 |
;;; On the other hand, if you *do* have a sophisticated compiler that will |
| 140 |
;;; actually perform soft-typing and eliminate redundant checks (Rice's systems |
| 141 |
;;; being the only possible candidate of which I'm aware), leaving these checks |
| 142 |
;;; in can *help*, since their presence can be elided in redundant cases, |
| 143 |
;;; and in cases where they are needed, performing the checks early, at |
| 144 |
;;; procedure entry, can "lift" a check out of a loop. |
| 145 |
;;; |
| 146 |
;;; Finally, I have only checked the properties that can portably be checked |
| 147 |
;;; with R5RS Scheme -- and this is not complete. You may wish to alter |
| 148 |
;;; the CHECK-ARG parameter checks to perform extra, implementation-specific |
| 149 |
;;; checks, such as procedure arity for higher-order values. |
| 150 |
;;; |
| 151 |
;;; The code has only these non-R4RS dependencies: |
| 152 |
;;; A few calls to an ERROR procedure; |
| 153 |
;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding |
| 154 |
;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). |
| 155 |
;;; Many calls to a parameter-checking procedure check-arg: |
| 156 |
;;; (define (check-arg pred val caller) |
| 157 |
;;; (let lp ((val val)) |
| 158 |
;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) |
| 159 |
;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing |
| 160 |
;;; optional arguments. |
| 161 |
;;; |
| 162 |
;;; Most of these procedures use the NULL-LIST? test to trigger the |
| 163 |
;;; base case in the inner loop or recursion. The NULL-LIST? function |
| 164 |
;;; is defined to be a careful one -- it raises an error if passed a |
| 165 |
;;; non-nil, non-pair value. The spec allows an implementation to use |
| 166 |
;;; a less-careful implementation that simply defines NULL-LIST? to |
| 167 |
;;; be NOT-PAIR?. This would speed up the inner loops of these procedures |
| 168 |
;;; at the expense of having them silently accept dotted lists. |
| 169 |
|
| 170 |
;;; A note on dotted lists: |
| 171 |
;;; I, personally, take the view that the only consistent view of lists |
| 172 |
;;; in Scheme is the view that *everything* is a list -- values such as |
| 173 |
;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the |
| 174 |
;;; fact that Scheme actually has no true list type. It has a pair type, |
| 175 |
;;; and there is an *interpretation* of the trees built using this type |
| 176 |
;;; as lists. |
| 177 |
;;; |
| 178 |
;;; I lobbied to have these list-processing procedures hew to this |
| 179 |
;;; view, and accept any value as a list argument. I was overwhelmingly |
| 180 |
;;; overruled during the SRFI discussion phase. So I am inserting this |
| 181 |
;;; text in the reference lib and the SRFI spec as a sort of "minority |
| 182 |
;;; opinion" dissent. |
| 183 |
;;; |
| 184 |
;;; Many of the procedures in this library can be trivially redefined |
| 185 |
;;; to handle dotted lists, just by changing the NULL-LIST? base-case |
| 186 |
;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be |
| 187 |
;;; an empty list. For most of these procedures, that's all that is |
| 188 |
;;; required. |
| 189 |
;;; |
| 190 |
;;; However, we have to do a little more work for some procedures that |
| 191 |
;;; *produce* lists from other lists. Were we to extend these procedures to |
| 192 |
;;; accept dotted lists, we would have to define how they terminate the lists |
| 193 |
;;; produced as results when passed a dotted list. I designed a coherent set |
| 194 |
;;; of termination rules for these cases; this was posted to the SRFI-1 |
| 195 |
;;; discussion list. I additionally wrote an earlier version of this library |
| 196 |
;;; that implemented that spec. It has been discarded during later phases of |
| 197 |
;;; the definition and implementation of this library. |
| 198 |
;;; |
| 199 |
;;; The argument *against* defining these procedures to work on dotted |
| 200 |
;;; lists is that dotted lists are the rare, odd case, and that by |
| 201 |
;;; arranging for the procedures to handle them, we lose error checking |
| 202 |
;;; in the cases where a dotted list is passed by accident -- e.g., when |
| 203 |
;;; the programmer swaps a two arguments to a list-processing function, |
| 204 |
;;; one being a scalar and one being a list. For example, |
| 205 |
;;; (member '(1 3 5 7 9) 7) |
| 206 |
;;; This would quietly return #f if we extended MEMBER to accept dotted |
| 207 |
;;; lists. |
| 208 |
;;; |
| 209 |
;;; The SRFI discussion record contains more discussion on this topic. |
| 210 |
|
| 211 |
|
| 212 |
;;; Constructors |
| 213 |
;;;;;;;;;;;;;;;; |
| 214 |
|
| 215 |
;;; Occasionally useful as a value to be passed to a fold or other |
| 216 |
;;; higher-order procedure. |
| 217 |
(define (xcons d a) (cons a d)) |
| 218 |
|
| 219 |
;;;; Recursively copy every cons. |
| 220 |
;(define (tree-copy x) |
| 221 |
; (let recur ((x x)) |
| 222 |
; (if (not (pair? x)) x |
| 223 |
; (cons (recur (car x)) (recur (cdr x)))))) |
| 224 |
|
| 225 |
;;; Make a list of length LEN. |
| 226 |
|
| 227 |
(define (make-list len . maybe-elt) |
| 228 |
(check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) |
| 229 |
(let ((elt (cond ((null? maybe-elt) #f) ; Default value |
| 230 |
((null? (cdr maybe-elt)) (car maybe-elt)) |
| 231 |
(else (error "Too many arguments to MAKE-LIST" |
| 232 |
(cons len maybe-elt)))))) |
| 233 |
(do ((i len (- i 1)) |
| 234 |
(ans '() (cons elt ans))) |
| 235 |
((<= i 0) ans)))) |
| 236 |
|
| 237 |
|
| 238 |
;(define (list . ans) ans) ; R4RS |
| 239 |
|
| 240 |
|
| 241 |
;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. |
| 242 |
|
| 243 |
(define (list-tabulate len proc) |
| 244 |
(check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) |
| 245 |
(check-arg procedure? proc list-tabulate) |
| 246 |
(do ((i (- len 1) (- i 1)) |
| 247 |
(ans '() (cons (proc i) ans))) |
| 248 |
((< i 0) ans))) |
| 249 |
|
| 250 |
;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) |
| 251 |
;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) |
| 252 |
;;; |
| 253 |
;;; (cons first (unfold not-pair? car cdr rest values)) |
| 254 |
|
| 255 |
(define (cons* first . rest) |
| 256 |
(let recur ((x first) (rest rest)) |
| 257 |
(if (pair? rest) |
| 258 |
(cons x (recur (car rest) (cdr rest))) |
| 259 |
x))) |
| 260 |
|
| 261 |
;;; (unfold not-pair? car cdr lis values) |
| 262 |
|
| 263 |
(define (list-copy lis) |
| 264 |
(let recur ((lis lis)) |
| 265 |
(if (pair? lis) |
| 266 |
(cons (car lis) (recur (cdr lis))) |
| 267 |
lis))) |
| 268 |
|
| 269 |
;;; IOTA count [start step] (start start+step ... start+(count-1)*step) |
| 270 |
|
| 271 |
(define (iota count . maybe-start+step) |
| 272 |
(check-arg integer? count iota) |
| 273 |
(if (< count 0) (error "Negative step count" iota count)) |
| 274 |
(let-optionals maybe-start+step ((start 0) (step 1)) |
| 275 |
(check-arg number? start iota) |
| 276 |
(check-arg number? step iota) |
| 277 |
(let loop ((n 0) (r '())) |
| 278 |
(if (= n count) |
| 279 |
(reverse r) |
| 280 |
(loop (+ 1 n) |
| 281 |
(cons (+ start (* n step)) r)))))) |
| 282 |
|
| 283 |
;;; I thought these were lovely, but the public at large did not share my |
| 284 |
;;; enthusiasm... |
| 285 |
;;; :IOTA to (0 ... to-1) |
| 286 |
;;; :IOTA from to (from ... to-1) |
| 287 |
;;; :IOTA from to step (from from+step ...) |
| 288 |
|
| 289 |
;;; IOTA: to (1 ... to) |
| 290 |
;;; IOTA: from to (from+1 ... to) |
| 291 |
;;; IOTA: from to step (from+step from+2step ...) |
| 292 |
|
| 293 |
;(define (%parse-iota-args arg1 rest-args proc) |
| 294 |
; (let ((check (lambda (n) (check-arg integer? n proc)))) |
| 295 |
; (check arg1) |
| 296 |
; (if (pair? rest-args) |
| 297 |
; (let ((arg2 (check (car rest-args))) |
| 298 |
; (rest (cdr rest-args))) |
| 299 |
; (if (pair? rest) |
| 300 |
; (let ((arg3 (check (car rest))) |
| 301 |
; (rest (cdr rest))) |
| 302 |
; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) |
| 303 |
; (values arg1 arg2 arg3))) |
| 304 |
; (values arg1 arg2 1))) |
| 305 |
; (values 0 arg1 1)))) |
| 306 |
; |
| 307 |
;(define (iota: arg1 . rest-args) |
| 308 |
; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) |
| 309 |
; (let* ((numsteps (floor (/ (- to from) step))) |
| 310 |
; (last-val (+ from (* step numsteps)))) |
| 311 |
; (if (< numsteps 0) (error "Negative step count" iota: from to step)) |
| 312 |
; (do ((steps-left numsteps (- steps-left 1)) |
| 313 |
; (val last-val (- val step)) |
| 314 |
; (ans '() (cons val ans))) |
| 315 |
; ((<= steps-left 0) ans))))) |
| 316 |
; |
| 317 |
; |
| 318 |
;(define (:iota arg1 . rest-args) |
| 319 |
; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) |
| 320 |
; (let* ((numsteps (ceiling (/ (- to from) step))) |
| 321 |
; (last-val (+ from (* step (- numsteps 1))))) |
| 322 |
; (if (< numsteps 0) (error "Negative step count" :iota from to step)) |
| 323 |
; (do ((steps-left numsteps (- steps-left 1)) |
| 324 |
; (val last-val (- val step)) |
| 325 |
; (ans '() (cons val ans))) |
| 326 |
; ((<= steps-left 0) ans))))) |
| 327 |
|
| 328 |
|
| 329 |
|
| 330 |
(define (circular-list val1 . vals) |
| 331 |
(let ((ans (cons val1 vals))) |
| 332 |
(set-cdr! (last-pair ans) ans) |
| 333 |
ans)) |
| 334 |
|
| 335 |
;;; <proper-list> ::= () ; Empty proper list |
| 336 |
;;; | (cons <x> <proper-list>) ; Proper-list pair |
| 337 |
;;; Note that this definition rules out circular lists -- and this |
| 338 |
;;; function is required to detect this case and return false. |
| 339 |
|
| 340 |
(define (proper-list? x) |
| 341 |
(let lp ((x x) (lag x)) |
| 342 |
(if (pair? x) |
| 343 |
(let ((x (cdr x))) |
| 344 |
(if (pair? x) |
| 345 |
(let ((x (cdr x)) |
| 346 |
(lag (cdr lag))) |
| 347 |
(and (not (eq? x lag)) (lp x lag))) |
| 348 |
(null? x))) |
| 349 |
(null? x)))) |
| 350 |
|
| 351 |
|
| 352 |
;;; A dotted list is a finite list (possibly of length 0) terminated |
| 353 |
;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) |
| 354 |
;;; is a dotted list of length 0. |
| 355 |
;;; |
| 356 |
;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list |
| 357 |
;;; | (cons <x> <dotted-list>) ; Proper-list pair |
| 358 |
|
| 359 |
(define (dotted-list? x) |
| 360 |
(let lp ((x x) (lag x)) |
| 361 |
(if (pair? x) |
| 362 |
(let ((x (cdr x))) |
| 363 |
(if (pair? x) |
| 364 |
(let ((x (cdr x)) |
| 365 |
(lag (cdr lag))) |
| 366 |
(and (not (eq? x lag)) (lp x lag))) |
| 367 |
(not (null? x)))) |
| 368 |
(not (null? x))))) |
| 369 |
|
| 370 |
(define (circular-list? x) |
| 371 |
(let lp ((x x) (lag x)) |
| 372 |
(and (pair? x) |
| 373 |
(let ((x (cdr x))) |
| 374 |
(and (pair? x) |
| 375 |
(let ((x (cdr x)) |
| 376 |
(lag (cdr lag))) |
| 377 |
(or (eq? x lag) (lp x lag)))))))) |
| 378 |
|
| 379 |
(define (not-pair? x) (not (pair? x))) ; Inline me. |
| 380 |
|
| 381 |
;;; This is a legal definition which is fast and sloppy: |
| 382 |
;;; (define null-list? not-pair?) |
| 383 |
;;; but we'll provide a more careful one: |
| 384 |
(define (null-list? l) |
| 385 |
(cond ((pair? l) #f) |
| 386 |
((null? l) #t) |
| 387 |
(else (error "null-list?: argument out of domain" l)))) |
| 388 |
|
| 389 |
|
| 390 |
(define (list= = . lists) |
| 391 |
(or (null? lists) ; special case |
| 392 |
|
| 393 |
(let lp1 ((list-a (car lists)) (others (cdr lists))) |
| 394 |
(or (null? others) |
| 395 |
(let ((list-b (car others)) |
| 396 |
(others (cdr others))) |
| 397 |
(if (eq? list-a list-b) ; EQ? => LIST= |
| 398 |
(lp1 list-b others) |
| 399 |
(let lp2 ((list-a list-a) (list-b list-b)) |
| 400 |
(if (null-list? list-a) |
| 401 |
(and (null-list? list-b) |
| 402 |
(lp1 list-b others)) |
| 403 |
(and (not (null-list? list-b)) |
| 404 |
(= (car list-a) (car list-b)) |
| 405 |
(lp2 (cdr list-a) (cdr list-b))))))))))) |
| 406 |
|
| 407 |
|
| 408 |
|
| 409 |
;;; R4RS, so commented out. |
| 410 |
;(define (length x) ; LENGTH may diverge or |
| 411 |
; (let lp ((x x) (len 0)) ; raise an error if X is |
| 412 |
; (if (pair? x) ; a circular list. This version |
| 413 |
; (lp (cdr x) (+ len 1)) ; diverges. |
| 414 |
; len))) |
| 415 |
|
| 416 |
(define (length+ x) ; Returns #f if X is circular. |
| 417 |
(let lp ((x x) (lag x) (len 0)) |
| 418 |
(if (pair? x) |
| 419 |
(let ((x (cdr x)) |
| 420 |
(len (+ len 1))) |
| 421 |
(if (pair? x) |
| 422 |
(let ((x (cdr x)) |
| 423 |
(lag (cdr lag)) |
| 424 |
(len (+ len 1))) |
| 425 |
(and (not (eq? x lag)) (lp x lag len))) |
| 426 |
len)) |
| 427 |
len))) |
| 428 |
|
| 429 |
(define (zip list1 . more-lists) (apply map list list1 more-lists)) |
| 430 |
|
| 431 |
|
| 432 |
;;; Selectors |
| 433 |
;;;;;;;;;;;;; |
| 434 |
|
| 435 |
;;; R4RS non-primitives: |
| 436 |
;(define (caar x) (car (car x))) |
| 437 |
;(define (cadr x) (car (cdr x))) |
| 438 |
;(define (cdar x) (cdr (car x))) |
| 439 |
;(define (cddr x) (cdr (cdr x))) |
| 440 |
; |
| 441 |
;(define (caaar x) (caar (car x))) |
| 442 |
;(define (caadr x) (caar (cdr x))) |
| 443 |
;(define (cadar x) (cadr (car x))) |
| 444 |
;(define (caddr x) (cadr (cdr x))) |
| 445 |
;(define (cdaar x) (cdar (car x))) |
| 446 |
;(define (cdadr x) (cdar (cdr x))) |
| 447 |
;(define (cddar x) (cddr (car x))) |
| 448 |
;(define (cdddr x) (cddr (cdr x))) |
| 449 |
; |
| 450 |
;(define (caaaar x) (caaar (car x))) |
| 451 |
;(define (caaadr x) (caaar (cdr x))) |
| 452 |
;(define (caadar x) (caadr (car x))) |
| 453 |
;(define (caaddr x) (caadr (cdr x))) |
| 454 |
;(define (cadaar x) (cadar (car x))) |
| 455 |
;(define (cadadr x) (cadar (cdr x))) |
| 456 |
;(define (caddar x) (caddr (car x))) |
| 457 |
;(define (cadddr x) (caddr (cdr x))) |
| 458 |
;(define (cdaaar x) (cdaar (car x))) |
| 459 |
;(define (cdaadr x) (cdaar (cdr x))) |
| 460 |
;(define (cdadar x) (cdadr (car x))) |
| 461 |
;(define (cdaddr x) (cdadr (cdr x))) |
| 462 |
;(define (cddaar x) (cddar (car x))) |
| 463 |
;(define (cddadr x) (cddar (cdr x))) |
| 464 |
;(define (cdddar x) (cdddr (car x))) |
| 465 |
;(define (cddddr x) (cdddr (cdr x))) |
| 466 |
|
| 467 |
|
| 468 |
(define first car) |
| 469 |
(define second cadr) |
| 470 |
(define third caddr) |
| 471 |
(define fourth cadddr) |
| 472 |
(define (fifth x) (car (cddddr x))) |
| 473 |
(define (sixth x) (cadr (cddddr x))) |
| 474 |
(define (seventh x) (caddr (cddddr x))) |
| 475 |
(define (eighth x) (cadddr (cddddr x))) |
| 476 |
(define (ninth x) (car (cddddr (cddddr x)))) |
| 477 |
(define (tenth x) (cadr (cddddr (cddddr x)))) |
| 478 |
|
| 479 |
(define (car+cdr pair) (values (car pair) (cdr pair))) |
| 480 |
|
| 481 |
;;; take & drop |
| 482 |
|
| 483 |
(define (take lis k) |
| 484 |
(check-arg integer? k take) |
| 485 |
(let recur ((lis lis) (k k)) |
| 486 |
(if (zero? k) '() |
| 487 |
(cons (car lis) |
| 488 |
(recur (cdr lis) (- k 1)))))) |
| 489 |
|
| 490 |
(define (drop lis k) |
| 491 |
(check-arg integer? k drop) |
| 492 |
(let iter ((lis lis) (k k)) |
| 493 |
(if (zero? k) lis (iter (cdr lis) (- k 1))))) |
| 494 |
|
| 495 |
(define (take! lis k) |
| 496 |
(check-arg integer? k take!) |
| 497 |
(if (zero? k) '() |
| 498 |
(begin (set-cdr! (drop lis (- k 1)) '()) |
| 499 |
lis))) |
| 500 |
|
| 501 |
;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, |
| 502 |
;;; off by K, then chasing down the list until the lead pointer falls off |
| 503 |
;;; the end. |
| 504 |
|
| 505 |
(define (take-right lis k) |
| 506 |
(check-arg integer? k take-right) |
| 507 |
(let lp ((lag lis) (lead (drop lis k))) |
| 508 |
(if (pair? lead) |
| 509 |
(lp (cdr lag) (cdr lead)) |
| 510 |
lag))) |
| 511 |
|
| 512 |
(define (drop-right lis k) |
| 513 |
(check-arg integer? k drop-right) |
| 514 |
(let recur ((lag lis) (lead (drop lis k))) |
| 515 |
(if (pair? lead) |
| 516 |
(cons (car lag) (recur (cdr lag) (cdr lead))) |
| 517 |
'()))) |
| 518 |
|
| 519 |
;;; In this function, LEAD is actually K+1 ahead of LAG. This lets |
| 520 |
;;; us stop LAG one step early, in time to smash its cdr to (). |
| 521 |
(define (drop-right! lis k) |
| 522 |
(check-arg integer? k drop-right!) |
| 523 |
(let ((lead (drop lis k))) |
| 524 |
(if (pair? lead) |
| 525 |
|
| 526 |
(let lp ((lag lis) (lead (cdr lead))) ; Standard case |
| 527 |
(if (pair? lead) |
| 528 |
(lp (cdr lag) (cdr lead)) |
| 529 |
(begin (set-cdr! lag '()) |
| 530 |
lis))) |
| 531 |
|
| 532 |
'()))) ; Special case dropping everything -- no cons to side-effect. |
| 533 |
|
| 534 |
;(define (list-ref lis i) (car (drop lis i))) ; R4RS |
| 535 |
|
| 536 |
;;; These use the APL convention, whereby negative indices mean |
| 537 |
;;; "from the right." I liked them, but they didn't win over the |
| 538 |
;;; SRFI reviewers. |
| 539 |
;;; K >= 0: Take and drop K elts from the front of the list. |
| 540 |
;;; K <= 0: Take and drop -K elts from the end of the list. |
| 541 |
|
| 542 |
;(define (take lis k) |
| 543 |
; (check-arg integer? k take) |
| 544 |
; (if (negative? k) |
| 545 |
; (list-tail lis (+ k (length lis))) |
| 546 |
; (let recur ((lis lis) (k k)) |
| 547 |
; (if (zero? k) '() |
| 548 |
; (cons (car lis) |
| 549 |
; (recur (cdr lis) (- k 1))))))) |
| 550 |
; |
| 551 |
;(define (drop lis k) |
| 552 |
; (check-arg integer? k drop) |
| 553 |
; (if (negative? k) |
| 554 |
; (let recur ((lis lis) (nelts (+ k (length lis)))) |
| 555 |
; (if (zero? nelts) '() |
| 556 |
; (cons (car lis) |
| 557 |
; (recur (cdr lis) (- nelts 1))))) |
| 558 |
; (list-tail lis k))) |
| 559 |
; |
| 560 |
; |
| 561 |
;(define (take! lis k) |
| 562 |
; (check-arg integer? k take!) |
| 563 |
; (cond ((zero? k) '()) |
| 564 |
; ((positive? k) |
| 565 |
; (set-cdr! (list-tail lis (- k 1)) '()) |
| 566 |
; lis) |
| 567 |
; (else (list-tail lis (+ k (length lis)))))) |
| 568 |
; |
| 569 |
;(define (drop! lis k) |
| 570 |
; (check-arg integer? k drop!) |
| 571 |
; (if (negative? k) |
| 572 |
; (let ((nelts (+ k (length lis)))) |
| 573 |
; (if (zero? nelts) '() |
| 574 |
; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) |
| 575 |
; lis))) |
| 576 |
; (list-tail lis k))) |
| 577 |
|
| 578 |
(define (split-at x k) |
| 579 |
(check-arg integer? k split-at) |
| 580 |
(let recur ((lis x) (k k)) |
| 581 |
(if (zero? k) (values '() lis) |
| 582 |
(receive (prefix suffix) (recur (cdr lis) (- k 1)) |
| 583 |
(values (cons (car lis) prefix) suffix))))) |
| 584 |
|
| 585 |
(define (split-at! x k) |
| 586 |
(check-arg integer? k split-at!) |
| 587 |
(if (zero? k) (values '() x) |
| 588 |
(let* ((prev (drop x (- k 1))) |
| 589 |
(suffix (cdr prev))) |
| 590 |
(set-cdr! prev '()) |
| 591 |
(values x suffix)))) |
| 592 |
|
| 593 |
|
| 594 |
(define (last lis) (car (last-pair lis))) |
| 595 |
|
| 596 |
(define (last-pair lis) |
| 597 |
(check-arg pair? lis last-pair) |
| 598 |
(let lp ((lis lis)) |
| 599 |
(let ((tail (cdr lis))) |
| 600 |
(if (pair? tail) (lp tail) lis)))) |
| 601 |
|
| 602 |
|
| 603 |
;;; Unzippers -- 1 through 5 |
| 604 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 605 |
|
| 606 |
(define (unzip1 lis) (map car lis)) |
| 607 |
|
| 608 |
(define (unzip2 lis) |
| 609 |
(let recur ((lis lis)) |
| 610 |
(if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle |
| 611 |
(let ((elt (car lis))) ; dotted lists. |
| 612 |
(receive (a b) (recur (cdr lis)) |
| 613 |
(values (cons (car elt) a) |
| 614 |
(cons (cadr elt) b))))))) |
| 615 |
|
| 616 |
(define (unzip3 lis) |
| 617 |
(let recur ((lis lis)) |
| 618 |
(if (null-list? lis) (values lis lis lis) |
| 619 |
(let ((elt (car lis))) |
| 620 |
(receive (a b c) (recur (cdr lis)) |
| 621 |
(values (cons (car elt) a) |
| 622 |
(cons (cadr elt) b) |
| 623 |
(cons (caddr elt) c))))))) |
| 624 |
|
| 625 |
(define (unzip4 lis) |
| 626 |
(let recur ((lis lis)) |
| 627 |
(if (null-list? lis) (values lis lis lis lis) |
| 628 |
(let ((elt (car lis))) |
| 629 |
(receive (a b c d) (recur (cdr lis)) |
| 630 |
(values (cons (car elt) a) |
| 631 |
(cons (cadr elt) b) |
| 632 |
(cons (caddr elt) c) |
| 633 |
(cons (cadddr elt) d))))))) |
| 634 |
|
| 635 |
(define (unzip5 lis) |
| 636 |
(let recur ((lis lis)) |
| 637 |
(if (null-list? lis) (values lis lis lis lis lis) |
| 638 |
(let ((elt (car lis))) |
| 639 |
(receive (a b c d e) (recur (cdr lis)) |
| 640 |
(values (cons (car elt) a) |
| 641 |
(cons (cadr elt) b) |
| 642 |
(cons (caddr elt) c) |
| 643 |
(cons (cadddr elt) d) |
| 644 |
(cons (car (cddddr elt)) e))))))) |
| 645 |
|
| 646 |
|
| 647 |
;;; append! append-reverse append-reverse! concatenate concatenate! |
| 648 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 649 |
|
| 650 |
(define (append! . lists) |
| 651 |
;; First, scan through lists looking for a non-empty one. |
| 652 |
(let lp ((lists lists) (prev '())) |
| 653 |
(if (not (pair? lists)) prev |
| 654 |
(let ((first (car lists)) |
| 655 |
(rest (cdr lists))) |
| 656 |
(if (not (pair? first)) (lp rest first) |
| 657 |
|
| 658 |
;; Now, do the splicing. |
| 659 |
(let lp2 ((tail-cons (last-pair first)) |
| 660 |
(rest rest)) |
| 661 |
(if (pair? rest) |
| 662 |
(let ((next (car rest)) |
| 663 |
(rest (cdr rest))) |
| 664 |
(set-cdr! tail-cons next) |
| 665 |
(lp2 (if (pair? next) (last-pair next) tail-cons) |
| 666 |
rest)) |
| 667 |
first))))))) |
| 668 |
|
| 669 |
;;; APPEND is R4RS. |
| 670 |
;(define (append . lists) |
| 671 |
; (if (pair? lists) |
| 672 |
; (let recur ((list1 (car lists)) (lists (cdr lists))) |
| 673 |
; (if (pair? lists) |
| 674 |
; (let ((tail (recur (car lists) (cdr lists)))) |
| 675 |
; (fold-right cons tail list1)) ; Append LIST1 & TAIL. |
| 676 |
; list1)) |
| 677 |
; '())) |
| 678 |
|
| 679 |
;(define (append-reverse rev-head tail) (fold cons tail rev-head)) |
| 680 |
|
| 681 |
;(define (append-reverse! rev-head tail) |
| 682 |
; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) |
| 683 |
; tail |
| 684 |
; rev-head)) |
| 685 |
|
| 686 |
;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. |
| 687 |
|
| 688 |
(define (append-reverse rev-head tail) |
| 689 |
(let lp ((rev-head rev-head) (tail tail)) |
| 690 |
(if (null-list? rev-head) tail |
| 691 |
(lp (cdr rev-head) (cons (car rev-head) tail))))) |
| 692 |
|
| 693 |
(define (append-reverse! rev-head tail) |
| 694 |
(let lp ((rev-head rev-head) (tail tail)) |
| 695 |
(if (null-list? rev-head) tail |
| 696 |
(let ((next-rev (cdr rev-head))) |
| 697 |
(set-cdr! rev-head tail) |
| 698 |
(lp next-rev rev-head))))) |
| 699 |
|
| 700 |
|
| 701 |
(define (concatenate lists) (reduce-right append '() lists)) |
| 702 |
(define (concatenate! lists) (reduce-right append! '() lists)) |
| 703 |
|
| 704 |
;;; Fold/map internal utilities |
| 705 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 706 |
;;; These little internal utilities are used by the general |
| 707 |
;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. |
| 708 |
;;; One the other hand, the n-ary cases are painfully inefficient as it is. |
| 709 |
;;; An aggressive implementation should simply re-write these functions |
| 710 |
;;; for raw efficiency; I have written them for as much clarity, portability, |
| 711 |
;;; and simplicity as can be achieved. |
| 712 |
;;; |
| 713 |
;;; I use the dreaded call/cc to do local aborts. A good compiler could |
| 714 |
;;; handle this with extreme efficiency. An implementation that provides |
| 715 |
;;; a one-shot, non-persistent continuation grabber could help the compiler |
| 716 |
;;; out by using that in place of the call/cc's in these routines. |
| 717 |
;;; |
| 718 |
;;; These functions have funky definitions that are precisely tuned to |
| 719 |
;;; the needs of the fold/map procs -- for example, to minimize the number |
| 720 |
;;; of times the argument lists need to be examined. |
| 721 |
|
| 722 |
;;; Return (map cdr lists). |
| 723 |
;;; However, if any element of LISTS is empty, just abort and return '(). |
| 724 |
(define (%cdrs lists) |
| 725 |
(call-with-current-continuation |
| 726 |
(lambda (abort) |
| 727 |
(let recur ((lists lists)) |
| 728 |
(if (pair? lists) |
| 729 |
(let ((lis (car lists))) |
| 730 |
(if (null-list? lis) (abort '()) |
| 731 |
(cons (cdr lis) (recur (cdr lists))))) |
| 732 |
'()))))) |
| 733 |
|
| 734 |
(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) |
| 735 |
(let recur ((lists lists)) |
| 736 |
(if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) |
| 737 |
|
| 738 |
;;; LISTS is a (not very long) non-empty list of lists. |
| 739 |
;;; Return two lists: the cars & the cdrs of the lists. |
| 740 |
;;; However, if any of the lists is empty, just abort and return [() ()]. |
| 741 |
|
| 742 |
(define (%cars+cdrs lists) |
| 743 |
(call-with-current-continuation |
| 744 |
(lambda (abort) |
| 745 |
(let recur ((lists lists)) |
| 746 |
(if (pair? lists) |
| 747 |
(receive (list other-lists) (car+cdr lists) |
| 748 |
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out |
| 749 |
(receive (a d) (car+cdr list) |
| 750 |
(receive (cars cdrs) (recur other-lists) |
| 751 |
(values (cons a cars) (cons d cdrs)))))) |
| 752 |
(values '() '())))))) |
| 753 |
|
| 754 |
;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the |
| 755 |
;;; cars list. What a hack. |
| 756 |
(define (%cars+cdrs+ lists cars-final) |
| 757 |
(call-with-current-continuation |
| 758 |
(lambda (abort) |
| 759 |
(let recur ((lists lists)) |
| 760 |
(if (pair? lists) |
| 761 |
(receive (list other-lists) (car+cdr lists) |
| 762 |
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out |
| 763 |
(receive (a d) (car+cdr list) |
| 764 |
(receive (cars cdrs) (recur other-lists) |
| 765 |
(values (cons a cars) (cons d cdrs)))))) |
| 766 |
(values (list cars-final) '())))))) |
| 767 |
|
| 768 |
;;; Like %CARS+CDRS, but blow up if any list is empty. |
| 769 |
(define (%cars+cdrs/no-test lists) |
| 770 |
(let recur ((lists lists)) |
| 771 |
(if (pair? lists) |
| 772 |
(receive (list other-lists) (car+cdr lists) |
| 773 |
(receive (a d) (car+cdr list) |
| 774 |
(receive (cars cdrs) (recur other-lists) |
| 775 |
(values (cons a cars) (cons d cdrs))))) |
| 776 |
(values '() '())))) |
| 777 |
|
| 778 |
|
| 779 |
;;; count |
| 780 |
;;;;;;;;; |
| 781 |
(define (count pred list1 . lists) |
| 782 |
(check-arg procedure? pred count) |
| 783 |
(if (pair? lists) |
| 784 |
|
| 785 |
;; N-ary case |
| 786 |
(let lp ((list1 list1) (lists lists) (i 0)) |
| 787 |
(if (null-list? list1) i |
| 788 |
(receive (as ds) (%cars+cdrs lists) |
| 789 |
(if (null? as) i |
| 790 |
(lp (cdr list1) ds |
| 791 |
(if (apply pred (car list1) as) (+ i 1) i)))))) |
| 792 |
|
| 793 |
;; Fast path |
| 794 |
(let lp ((lis list1) (i 0)) |
| 795 |
(if (null-list? lis) i |
| 796 |
(lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) |
| 797 |
|
| 798 |
|
| 799 |
;;; fold/unfold |
| 800 |
;;;;;;;;;;;;;;; |
| 801 |
|
| 802 |
(define (unfold-right p f g seed . maybe-tail) |
| 803 |
(check-arg procedure? p unfold-right) |
| 804 |
(check-arg procedure? f unfold-right) |
| 805 |
(check-arg procedure? g unfold-right) |
| 806 |
(let lp ((seed seed) (ans (:optional maybe-tail '()))) |
| 807 |
(if (p seed) ans |
| 808 |
(lp (g seed) |
| 809 |
(cons (f seed) ans))))) |
| 810 |
|
| 811 |
|
| 812 |
(define (unfold p f g seed . maybe-tail-gen) |
| 813 |
(check-arg procedure? p unfold) |
| 814 |
(check-arg procedure? f unfold) |
| 815 |
(check-arg procedure? g unfold) |
| 816 |
(if (pair? maybe-tail-gen) |
| 817 |
|
| 818 |
(let ((tail-gen (car maybe-tail-gen))) |
| 819 |
(if (pair? (cdr maybe-tail-gen)) |
| 820 |
(apply error "Too many arguments" unfold p f g seed maybe-tail-gen) |
| 821 |
|
| 822 |
(let recur ((seed seed)) |
| 823 |
(if (p seed) (tail-gen seed) |
| 824 |
(cons (f seed) (recur (g seed))))))) |
| 825 |
|
| 826 |
(let recur ((seed seed)) |
| 827 |
(if (p seed) '() |
| 828 |
(cons (f seed) (recur (g seed))))))) |
| 829 |
|
| 830 |
|
| 831 |
(define (fold kons knil lis1 . lists) |
| 832 |
(check-arg procedure? kons fold) |
| 833 |
(if (pair? lists) |
| 834 |
(let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case |
| 835 |
(receive (cars+ans cdrs) (%cars+cdrs+ lists ans) |
| 836 |
(if (null? cars+ans) ans ; Done. |
| 837 |
(lp cdrs (apply kons cars+ans))))) |
| 838 |
|
| 839 |
(let lp ((lis lis1) (ans knil)) ; Fast path |
| 840 |
(if (null-list? lis) ans |
| 841 |
(lp (cdr lis) (kons (car lis) ans)))))) |
| 842 |
|
| 843 |
|
| 844 |
(define (fold-right kons knil lis1 . lists) |
| 845 |
(check-arg procedure? kons fold-right) |
| 846 |
(if (pair? lists) |
| 847 |
(let recur ((lists (cons lis1 lists))) ; N-ary case |
| 848 |
(let ((cdrs (%cdrs lists))) |
| 849 |
(if (null? cdrs) knil |
| 850 |
(apply kons (%cars+ lists (recur cdrs)))))) |
| 851 |
|
| 852 |
(let recur ((lis lis1)) ; Fast path |
| 853 |
(if (null-list? lis) knil |
| 854 |
(let ((head (car lis))) |
| 855 |
(kons head (recur (cdr lis)))))))) |
| 856 |
|
| 857 |
|
| 858 |
(define (pair-fold-right f zero lis1 . lists) |
| 859 |
(check-arg procedure? f pair-fold-right) |
| 860 |
(if (pair? lists) |
| 861 |
(let recur ((lists (cons lis1 lists))) ; N-ary case |
| 862 |
(let ((cdrs (%cdrs lists))) |
| 863 |
(if (null? cdrs) zero |
| 864 |
(apply f (append! lists (list (recur cdrs))))))) |
| 865 |
|
| 866 |
(let recur ((lis lis1)) ; Fast path |
| 867 |
(if (null-list? lis) zero (f lis (recur (cdr lis))))))) |
| 868 |
|
| 869 |
(define (pair-fold f zero lis1 . lists) |
| 870 |
(check-arg procedure? f pair-fold) |
| 871 |
(if (pair? lists) |
| 872 |
(let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case |
| 873 |
(let ((tails (%cdrs lists))) |
| 874 |
(if (null? tails) ans |
| 875 |
(lp tails (apply f (append! lists (list ans))))))) |
| 876 |
|
| 877 |
(let lp ((lis lis1) (ans zero)) |
| 878 |
(if (null-list? lis) ans |
| 879 |
(let ((tail (cdr lis))) ; Grab the cdr now, |
| 880 |
(lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. |
| 881 |
|
| 882 |
|
| 883 |
;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. |
| 884 |
;;; These cannot meaningfully be n-ary. |
| 885 |
|
| 886 |
(define (reduce f ridentity lis) |
| 887 |
(check-arg procedure? f reduce) |
| 888 |
(if (null-list? lis) ridentity |
| 889 |
(fold f (car lis) (cdr lis)))) |
| 890 |
|
| 891 |
(define (reduce-right f ridentity lis) |
| 892 |
(check-arg procedure? f reduce-right) |
| 893 |
(if (null-list? lis) ridentity |
| 894 |
(let recur ((head (car lis)) (lis (cdr lis))) |
| 895 |
(if (pair? lis) |
| 896 |
(f head (recur (car lis) (cdr lis))) |
| 897 |
head)))) |
| 898 |
|
| 899 |
|
| 900 |
|
| 901 |
;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order |
| 902 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 903 |
|
| 904 |
(define (append-map f lis1 . lists) |
| 905 |
(really-append-map append-map append f lis1 lists)) |
| 906 |
(define (append-map! f lis1 . lists) |
| 907 |
(really-append-map append-map! append! f lis1 lists)) |
| 908 |
|
| 909 |
(define (really-append-map who appender f lis1 lists) |
| 910 |
(check-arg procedure? f who) |
| 911 |
(if (pair? lists) |
| 912 |
(receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) |
| 913 |
(if (null? cars) '() |
| 914 |
(let recur ((cars cars) (cdrs cdrs)) |
| 915 |
(let ((vals (apply f cars))) |
| 916 |
(receive (cars2 cdrs2) (%cars+cdrs cdrs) |
| 917 |
(if (null? cars2) vals |
| 918 |
(appender vals (recur cars2 cdrs2)))))))) |
| 919 |
|
| 920 |
;; Fast path |
| 921 |
(if (null-list? lis1) '() |
| 922 |
(let recur ((elt (car lis1)) (rest (cdr lis1))) |
| 923 |
(let ((vals (f elt))) |
| 924 |
(if (null-list? rest) vals |
| 925 |
(appender vals (recur (car rest) (cdr rest))))))))) |
| 926 |
|
| 927 |
|
| 928 |
(define (pair-for-each proc lis1 . lists) |
| 929 |
(check-arg procedure? proc pair-for-each) |
| 930 |
(if (pair? lists) |
| 931 |
|
| 932 |
(let lp ((lists (cons lis1 lists))) |
| 933 |
(let ((tails (%cdrs lists))) |
| 934 |
(if (pair? tails) |
| 935 |
(begin (apply proc lists) |
| 936 |
(lp tails))))) |
| 937 |
|
| 938 |
;; Fast path. |
| 939 |
(let lp ((lis lis1)) |
| 940 |
(if (not (null-list? lis)) |
| 941 |
(let ((tail (cdr lis))) ; Grab the cdr now, |
| 942 |
(proc lis) ; in case PROC SET-CDR!s LIS. |
| 943 |
(lp tail)))))) |
| 944 |
|
| 945 |
;;; We stop when LIS1 runs out, not when any list runs out. |
| 946 |
(define (map! f lis1 . lists) |
| 947 |
(check-arg procedure? f map!) |
| 948 |
(if (pair? lists) |
| 949 |
(let lp ((lis1 lis1) (lists lists)) |
| 950 |
(if (not (null-list? lis1)) |
| 951 |
(receive (heads tails) (%cars+cdrs/no-test lists) |
| 952 |
(set-car! lis1 (apply f (car lis1) heads)) |
| 953 |
(lp (cdr lis1) tails)))) |
| 954 |
|
| 955 |
;; Fast path. |
| 956 |
(pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) |
| 957 |
lis1) |
| 958 |
|
| 959 |
|
| 960 |
;;; Map F across L, and save up all the non-false results. |
| 961 |
(define (filter-map f lis1 . lists) |
| 962 |
(check-arg procedure? f filter-map) |
| 963 |
(if (pair? lists) |
| 964 |
(let recur ((lists (cons lis1 lists))) |
| 965 |
(receive (cars cdrs) (%cars+cdrs lists) |
| 966 |
(if (pair? cars) |
| 967 |
(cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) |
| 968 |
(else (recur cdrs))) ; Tail call in this arm. |
| 969 |
'()))) |
| 970 |
|
| 971 |
;; Fast path. |
| 972 |
(let recur ((lis lis1)) |
| 973 |
(if (null-list? lis) lis |
| 974 |
(let ((tail (recur (cdr lis)))) |
| 975 |
(cond ((f (car lis)) => (lambda (x) (cons x tail))) |
| 976 |
(else tail))))))) |
| 977 |
|
| 978 |
|
| 979 |
;;; Map F across lists, guaranteeing to go left-to-right. |
| 980 |
;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; |
| 981 |
;;; in which case this procedure may simply be defined as a synonym for MAP. |
| 982 |
|
| 983 |
(define (map-in-order f lis1 . lists) |
| 984 |
(check-arg procedure? f map-in-order) |
| 985 |
(if (pair? lists) |
| 986 |
(let recur ((lists (cons lis1 lists))) |
| 987 |
(receive (cars cdrs) (%cars+cdrs lists) |
| 988 |
(if (pair? cars) |
| 989 |
(let ((x (apply f cars))) ; Do head first, |
| 990 |
(cons x (recur cdrs))) ; then tail. |
| 991 |
'()))) |
| 992 |
|
| 993 |
;; Fast path. |
| 994 |
(let recur ((lis lis1)) |
| 995 |
(if (null-list? lis) lis |
| 996 |
(let ((tail (cdr lis)) |
| 997 |
(x (f (car lis)))) ; Do head first, |
| 998 |
(cons x (recur tail))))))) ; then tail. |
| 999 |
|
| 1000 |
|
| 1001 |
;;; We extend MAP to handle arguments of unequal length. |
| 1002 |
(define map map-in-order) |
| 1003 |
|
| 1004 |
|
| 1005 |
;;; filter, remove, partition |
| 1006 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1007 |
;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not |
| 1008 |
;;; disorder the elements of their argument. |
| 1009 |
|
| 1010 |
;; This FILTER shares the longest tail of L that has no deleted elements. |
| 1011 |
;; If Scheme had multi-continuation calls, they could be made more efficient. |
| 1012 |
|
| 1013 |
(define (filter pred lis) ; Sleazing with EQ? makes this |
| 1014 |
(check-arg procedure? pred filter) ; one faster. |
| 1015 |
(let recur ((lis lis)) |
| 1016 |
(if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. |
| 1017 |
(let ((head (car lis)) |
| 1018 |
(tail (cdr lis))) |
| 1019 |
(if (pred head) |
| 1020 |
(let ((new-tail (recur tail))) ; Replicate the RECUR call so |
| 1021 |
(if (eq? tail new-tail) lis |
| 1022 |
(cons head new-tail))) |
| 1023 |
(recur tail)))))) ; this one can be a tail call. |
| 1024 |
|
| 1025 |
|
| 1026 |
;;; Another version that shares longest tail. |
| 1027 |
;(define (filter pred lis) |
| 1028 |
; (receive (ans no-del?) |
| 1029 |
; ;; (recur l) returns L with (pred x) values filtered. |
| 1030 |
; ;; It also returns a flag NO-DEL? if the returned value |
| 1031 |
; ;; is EQ? to L, i.e. if it didn't have to delete anything. |
| 1032 |
; (let recur ((l l)) |
| 1033 |
; (if (null-list? l) (values l #t) |
| 1034 |
; (let ((x (car l)) |
| 1035 |
; (tl (cdr l))) |
| 1036 |
; (if (pred x) |
| 1037 |
; (receive (ans no-del?) (recur tl) |
| 1038 |
; (if no-del? |
| 1039 |
; (values l #t) |
| 1040 |
; (values (cons x ans) #f))) |
| 1041 |
; (receive (ans no-del?) (recur tl) ; Delete X. |
| 1042 |
; (values ans #f)))))) |
| 1043 |
; ans)) |
| 1044 |
|
| 1045 |
|
| 1046 |
|
| 1047 |
;(define (filter! pred lis) ; Things are much simpler |
| 1048 |
; (let recur ((lis lis)) ; if you are willing to |
| 1049 |
; (if (pair? lis) ; push N stack frames & do N |
| 1050 |
; (cond ((pred (car lis)) ; SET-CDR! writes, where N is |
| 1051 |
; (set-cdr! lis (recur (cdr lis))); the length of the answer. |
| 1052 |
; lis) |
| 1053 |
; (else (recur (cdr lis)))) |
| 1054 |
; lis))) |
| 1055 |
|
| 1056 |
|
| 1057 |
;;; This implementation of FILTER! |
| 1058 |
;;; - doesn't cons, and uses no stack; |
| 1059 |
;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are |
| 1060 |
;;; usually expensive on modern machines, and can be extremely expensive on |
| 1061 |
;;; modern Schemes (e.g., ones that have generational GC's). |
| 1062 |
;;; It just zips down contiguous runs of in and out elts in LIS doing the |
| 1063 |
;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the |
| 1064 |
;;; beginning of the next. |
| 1065 |
|
| 1066 |
(define (filter! pred lis) |
| 1067 |
(check-arg procedure? pred filter!) |
| 1068 |
(let lp ((ans lis)) |
| 1069 |
(cond ((null-list? ans) ans) ; Scan looking for |
| 1070 |
((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. |
| 1071 |
|
| 1072 |
;; ANS is the eventual answer. |
| 1073 |
;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. |
| 1074 |
;; Scan over a contiguous segment of the list that |
| 1075 |
;; satisfies PRED. |
| 1076 |
;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous |
| 1077 |
;; segment of the list that *doesn't* satisfy PRED. |
| 1078 |
;; When the segment ends, patch in a link from PREV |
| 1079 |
;; to the start of the next good segment, and jump to |
| 1080 |
;; SCAN-IN. |
| 1081 |
(else (letrec ((scan-in (lambda (prev lis) |
| 1082 |
(if (pair? lis) |
| 1083 |
(if (pred (car lis)) |
| 1084 |
(scan-in lis (cdr lis)) |
| 1085 |
(scan-out prev (cdr lis)))))) |
| 1086 |
(scan-out (lambda (prev lis) |
| 1087 |
(let lp ((lis lis)) |
| 1088 |
(if (pair? lis) |
| 1089 |
(if (pred (car lis)) |
| 1090 |
(begin (set-cdr! prev lis) |
| 1091 |
(scan-in lis (cdr lis))) |
| 1092 |
(lp (cdr lis))) |
| 1093 |
(set-cdr! prev lis)))))) |
| 1094 |
(scan-in ans (cdr ans)) |
| 1095 |
ans))))) |
| 1096 |
|
| 1097 |
|
| 1098 |
|
| 1099 |
;;; Answers share common tail with LIS where possible; |
| 1100 |
;;; the technique is slightly subtle. |
| 1101 |
|
| 1102 |
(define (partition pred lis) |
| 1103 |
(check-arg procedure? pred partition) |
| 1104 |
(let recur ((lis lis)) |
| 1105 |
(if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. |
| 1106 |
(let ((elt (car lis)) |
| 1107 |
(tail (cdr lis))) |
| 1108 |
(receive (in out) (recur tail) |
| 1109 |
(if (pred elt) |
| 1110 |
(values (if (pair? out) (cons elt in) lis) out) |
| 1111 |
(values in (if (pair? in) (cons elt out) lis)))))))) |
| 1112 |
|
| 1113 |
|
| 1114 |
|
| 1115 |
;(define (partition! pred lis) ; Things are much simpler |
| 1116 |
; (let recur ((lis lis)) ; if you are willing to |
| 1117 |
; (if (null-list? lis) (values lis lis) ; push N stack frames & do N |
| 1118 |
; (let ((elt (car lis))) ; SET-CDR! writes, where N is |
| 1119 |
; (receive (in out) (recur (cdr lis)) ; the length of LIS. |
| 1120 |
; (cond ((pred elt) |
| 1121 |
; (set-cdr! lis in) |
| 1122 |
; (values lis out)) |
| 1123 |
; (else (set-cdr! lis out) |
| 1124 |
; (values in lis)))))))) |
| 1125 |
|
| 1126 |
|
| 1127 |
;;; This implementation of PARTITION! |
| 1128 |
;;; - doesn't cons, and uses no stack; |
| 1129 |
;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are |
| 1130 |
;;; usually expensive on modern machines, and can be extremely expensive on |
| 1131 |
;;; modern Schemes (e.g., ones that have generational GC's). |
| 1132 |
;;; It just zips down contiguous runs of in and out elts in LIS doing the |
| 1133 |
;;; minimal number of SET-CDR!s to splice these runs together into the result |
| 1134 |
;;; lists. |
| 1135 |
|
| 1136 |
(define (partition! pred lis) |
| 1137 |
(check-arg procedure? pred partition!) |
| 1138 |
(if (null-list? lis) (values lis lis) |
| 1139 |
|
| 1140 |
;; This pair of loops zips down contiguous in & out runs of the |
| 1141 |
;; list, splicing the runs together. The invariants are |
| 1142 |
;; SCAN-IN: (cdr in-prev) = LIS. |
| 1143 |
;; SCAN-OUT: (cdr out-prev) = LIS. |
| 1144 |
(letrec ((scan-in (lambda (in-prev out-prev lis) |
| 1145 |
(let lp ((in-prev in-prev) (lis lis)) |
| 1146 |
(if (pair? lis) |
| 1147 |
(if (pred (car lis)) |
| 1148 |
(lp lis (cdr lis)) |
| 1149 |
(begin (set-cdr! out-prev lis) |
| 1150 |
(scan-out in-prev lis (cdr lis)))) |
| 1151 |
(set-cdr! out-prev lis))))) ; Done. |
| 1152 |
|
| 1153 |
(scan-out (lambda (in-prev out-prev lis) |
| 1154 |
(let lp ((out-prev out-prev) (lis lis)) |
| 1155 |
(if (pair? lis) |
| 1156 |
(if (pred (car lis)) |
| 1157 |
(begin (set-cdr! in-prev lis) |
| 1158 |
(scan-in lis out-prev (cdr lis))) |
| 1159 |
(lp lis (cdr lis))) |
| 1160 |
(set-cdr! in-prev lis)))))) ; Done. |
| 1161 |
|
| 1162 |
;; Crank up the scan&splice loops. |
| 1163 |
(if (pred (car lis)) |
| 1164 |
;; LIS begins in-list. Search for out-list's first pair. |
| 1165 |
(let lp ((prev-l lis) (l (cdr lis))) |
| 1166 |
(cond ((not (pair? l)) (values lis l)) |
| 1167 |
((pred (car l)) (lp l (cdr l))) |
| 1168 |
(else (scan-out prev-l l (cdr l)) |
| 1169 |
(values lis l)))) ; Done. |
| 1170 |
|
| 1171 |
;; LIS begins out-list. Search for in-list's first pair. |
| 1172 |
(let lp ((prev-l lis) (l (cdr lis))) |
| 1173 |
(cond ((not (pair? l)) (values l lis)) |
| 1174 |
((pred (car l)) |
| 1175 |
(scan-in l prev-l (cdr l)) |
| 1176 |
(values l lis)) ; Done. |
| 1177 |
(else (lp l (cdr l))))))))) |
| 1178 |
|
| 1179 |
|
| 1180 |
;;; Inline us, please. |
| 1181 |
(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) |
| 1182 |
(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) |
| 1183 |
|
| 1184 |
|
| 1185 |
|
| 1186 |
;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. |
| 1187 |
;;; (I don't actually think these are the world's most important |
| 1188 |
;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants |
| 1189 |
;;; are far more general.) |
| 1190 |
;;; |
| 1191 |
;;; Function Action |
| 1192 |
;;; --------------------------------------------------------------------------- |
| 1193 |
;;; remove pred lis Delete by general predicate |
| 1194 |
;;; delete x lis [=] Delete by element comparison |
| 1195 |
;;; |
| 1196 |
;;; find pred lis Search by general predicate |
| 1197 |
;;; find-tail pred lis Search by general predicate |
| 1198 |
;;; member x lis [=] Search by element comparison |
| 1199 |
;;; |
| 1200 |
;;; assoc key lis [=] Search alist by key comparison |
| 1201 |
;;; alist-delete key alist [=] Alist-delete by key comparison |
| 1202 |
|
| 1203 |
(define (delete x lis . maybe-=) |
| 1204 |
(let ((= (:optional maybe-= equal?))) |
| 1205 |
(filter (lambda (y) (not (= x y))) lis))) |
| 1206 |
|
| 1207 |
(define (delete! x lis . maybe-=) |
| 1208 |
(let ((= (:optional maybe-= equal?))) |
| 1209 |
(filter! (lambda (y) (not (= x y))) lis))) |
| 1210 |
|
| 1211 |
;;; Extended from R4RS to take an optional comparison argument. |
| 1212 |
(define (member x lis . maybe-=) |
| 1213 |
(let ((= (:optional maybe-= equal?))) |
| 1214 |
(find-tail (lambda (y) (= x y)) lis))) |
| 1215 |
|
| 1216 |
;;; R4RS, hence we don't bother to define. |
| 1217 |
;;; The MEMBER and then FIND-TAIL call should definitely |
| 1218 |
;;; be inlined for MEMQ & MEMV. |
| 1219 |
;(define (memq x lis) (member x lis eq?)) |
| 1220 |
;(define (memv x lis) (member x lis eqv?)) |
| 1221 |
|
| 1222 |
|
| 1223 |
;;; right-duplicate deletion |
| 1224 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1225 |
;;; delete-duplicates delete-duplicates! |
| 1226 |
;;; |
| 1227 |
;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates |
| 1228 |
;;; in long lists, sort the list to bring duplicates together, then use a |
| 1229 |
;;; linear-time algorithm to kill the dups. Or use an algorithm based on |
| 1230 |
;;; element-marking. The former gives you O(n lg n), the latter is linear. |
| 1231 |
|
| 1232 |
(define (delete-duplicates lis . maybe-=) |
| 1233 |
(let ((elt= (:optional maybe-= equal?))) |
| 1234 |
(check-arg procedure? elt= delete-duplicates) |
| 1235 |
(let recur ((lis lis)) |
| 1236 |
(if (null-list? lis) lis |
| 1237 |
(let* ((x (car lis)) |
| 1238 |
(tail (cdr lis)) |
| 1239 |
(new-tail (recur (delete x tail elt=)))) |
| 1240 |
(if (eq? tail new-tail) lis (cons x new-tail))))))) |
| 1241 |
|
| 1242 |
(define (delete-duplicates! lis maybe-=) |
| 1243 |
(let ((elt= (:optional maybe-= equal?))) |
| 1244 |
(check-arg procedure? elt= delete-duplicates!) |
| 1245 |
(let recur ((lis lis)) |
| 1246 |
(if (null-list? lis) lis |
| 1247 |
(let* ((x (car lis)) |
| 1248 |
(tail (cdr lis)) |
| 1249 |
(new-tail (recur (delete! x tail elt=)))) |
| 1250 |
(if (eq? tail new-tail) lis (cons x new-tail))))))) |
| 1251 |
|
| 1252 |
|
| 1253 |
;;; alist stuff |
| 1254 |
;;;;;;;;;;;;;;; |
| 1255 |
|
| 1256 |
;;; Extended from R4RS to take an optional comparison argument. |
| 1257 |
(define (assoc x lis . maybe-=) |
| 1258 |
(let ((= (:optional maybe-= equal?))) |
| 1259 |
(find (lambda (entry) (= x (car entry))) lis))) |
| 1260 |
|
| 1261 |
(define (alist-cons key datum alist) (cons (cons key datum) alist)) |
| 1262 |
|
| 1263 |
(define (alist-copy alist) |
| 1264 |
(map (lambda (elt) (cons (car elt) (cdr elt))) |
| 1265 |
alist)) |
| 1266 |
|
| 1267 |
(define (alist-delete key alist . maybe-=) |
| 1268 |
(let ((= (:optional maybe-= equal?))) |
| 1269 |
(filter (lambda (elt) (not (= key (car elt)))) alist))) |
| 1270 |
|
| 1271 |
(define (alist-delete! key alist . maybe-=) |
| 1272 |
(let ((= (:optional maybe-= equal?))) |
| 1273 |
(filter! (lambda (elt) (not (= key (car elt)))) alist))) |
| 1274 |
|
| 1275 |
|
| 1276 |
;;; find find-tail take-while drop-while span break any every list-index |
| 1277 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1278 |
|
| 1279 |
(define (find pred list) |
| 1280 |
(cond ((find-tail pred list) => car) |
| 1281 |
(else #f))) |
| 1282 |
|
| 1283 |
(define (find-tail pred list) |
| 1284 |
(check-arg procedure? pred find-tail) |
| 1285 |
(let lp ((list list)) |
| 1286 |
(and (not (null-list? list)) |
| 1287 |
(if (pred (car list)) list |
| 1288 |
(lp (cdr list)))))) |
| 1289 |
|
| 1290 |
(define (take-while pred lis) |
| 1291 |
(check-arg procedure? pred take-while) |
| 1292 |
(let recur ((lis lis)) |
| 1293 |
(if (null-list? lis) '() |
| 1294 |
(let ((x (car lis))) |
| 1295 |
(if (pred x) |
| 1296 |
(cons x (recur (cdr lis))) |
| 1297 |
'()))))) |
| 1298 |
|
| 1299 |
(define (drop-while pred lis) |
| 1300 |
(check-arg procedure? pred drop-while) |
| 1301 |
(let lp ((lis lis)) |
| 1302 |
(if (null-list? lis) '() |
| 1303 |
(if (pred (car lis)) |
| 1304 |
(lp (cdr lis)) |
| 1305 |
lis)))) |
| 1306 |
|
| 1307 |
(define (take-while! pred lis) |
| 1308 |
(check-arg procedure? pred take-while!) |
| 1309 |
(if (or (null-list? lis) (not (pred (car lis)))) '() |
| 1310 |
(begin (let lp ((prev lis) (rest (cdr lis))) |
| 1311 |
(if (pair? rest) |
| 1312 |
(let ((x (car rest))) |
| 1313 |
(if (pred x) (lp rest (cdr rest)) |
| 1314 |
(set-cdr! prev '()))))) |
| 1315 |
lis))) |
| 1316 |
|
| 1317 |
(define (span pred lis) |
| 1318 |
(check-arg procedure? pred span) |
| 1319 |
(let recur ((lis lis)) |
| 1320 |
(if (null-list? lis) (values '() '()) |
| 1321 |
(let ((x (car lis))) |
| 1322 |
(if (pred x) |
| 1323 |
(receive (prefix suffix) (recur (cdr lis)) |
| 1324 |
(values (cons x prefix) suffix)) |
| 1325 |
(values '() lis)))))) |
| 1326 |
|
| 1327 |
(define (span! pred lis) |
| 1328 |
(check-arg procedure? pred span!) |
| 1329 |
(if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) |
| 1330 |
(let ((suffix (let lp ((prev lis) (rest (cdr lis))) |
| 1331 |
(if (null-list? rest) rest |
| 1332 |
(let ((x (car rest))) |
| 1333 |
(if (pred x) (lp rest (cdr rest)) |
| 1334 |
(begin (set-cdr! prev '()) |
| 1335 |
rest))))))) |
| 1336 |
(values lis suffix)))) |
| 1337 |
|
| 1338 |
|
| 1339 |
(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) |
| 1340 |
(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) |
| 1341 |
|
| 1342 |
(define (any pred lis1 . lists) |
| 1343 |
(check-arg procedure? pred any) |
| 1344 |
(if (pair? lists) |
| 1345 |
|
| 1346 |
;; N-ary case |
| 1347 |
(receive (heads tails) (%cars+cdrs (cons lis1 lists)) |
| 1348 |
(and (pair? heads) |
| 1349 |
(let lp ((heads heads) (tails tails)) |
| 1350 |
(receive (next-heads next-tails) (%cars+cdrs tails) |
| 1351 |
(if (pair? next-heads) |
| 1352 |
(or (apply pred heads) (lp next-heads next-tails)) |
| 1353 |
(apply pred heads)))))) ; Last PRED app is tail call. |
| 1354 |
|
| 1355 |
;; Fast path |
| 1356 |
(and (not (null-list? lis1)) |
| 1357 |
(let lp ((head (car lis1)) (tail (cdr lis1))) |
| 1358 |
(if (null-list? tail) |
| 1359 |
(pred head) ; Last PRED app is tail call. |
| 1360 |
(or (pred head) (lp (car tail) (cdr tail)))))))) |
| 1361 |
|
| 1362 |
|
| 1363 |
;(define (every pred list) ; Simple definition. |
| 1364 |
; (let lp ((list list)) ; Doesn't return the last PRED value. |
| 1365 |
; (or (not (pair? list)) |
| 1366 |
; (and (pred (car list)) |
| 1367 |
; (lp (cdr list)))))) |
| 1368 |
|
| 1369 |
(define (every pred lis1 . lists) |
| 1370 |
(check-arg procedure? pred every) |
| 1371 |
(if (pair? lists) |
| 1372 |
|
| 1373 |
;; N-ary case |
| 1374 |
(receive (heads tails) (%cars+cdrs (cons lis1 lists)) |
| 1375 |
(or (not (pair? heads)) |
| 1376 |
(let lp ((heads heads) (tails tails)) |
| 1377 |
(receive (next-heads next-tails) (%cars+cdrs tails) |
| 1378 |
(if (pair? next-heads) |
| 1379 |
(and (apply pred heads) (lp next-heads next-tails)) |
| 1380 |
(apply pred heads)))))) ; Last PRED app is tail call. |
| 1381 |
|
| 1382 |
;; Fast path |
| 1383 |
(or (null-list? lis1) |
| 1384 |
(let lp ((head (car lis1)) (tail (cdr lis1))) |
| 1385 |
(if (null-list? tail) |
| 1386 |
(pred head) ; Last PRED app is tail call. |
| 1387 |
(and (pred head) (lp (car tail) (cdr tail)))))))) |
| 1388 |
|
| 1389 |
(define (list-index pred lis1 . lists) |
| 1390 |
(check-arg procedure? pred list-index) |
| 1391 |
(if (pair? lists) |
| 1392 |
|
| 1393 |
;; N-ary case |
| 1394 |
(let lp ((lists (cons lis1 lists)) (n 0)) |
| 1395 |
(receive (heads tails) (%cars+cdrs lists) |
| 1396 |
(and (pair? heads) |
| 1397 |
(if (apply pred heads) n |
| 1398 |
(lp tails (+ n 1)))))) |
| 1399 |
|
| 1400 |
;; Fast path |
| 1401 |
(let lp ((lis lis1) (n 0)) |
| 1402 |
(and (not (null-list? lis)) |
| 1403 |
(if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) |
| 1404 |
|
| 1405 |
;;; Reverse |
| 1406 |
;;;;;;;;;;; |
| 1407 |
|
| 1408 |
;R4RS, so not defined here. |
| 1409 |
;(define (reverse lis) (fold cons '() lis)) |
| 1410 |
|
| 1411 |
;(define (reverse! lis) |
| 1412 |
; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) |
| 1413 |
|
| 1414 |
(define (reverse! lis) |
| 1415 |
(let lp ((lis lis) (ans '())) |
| 1416 |
(if (null-list? lis) ans |
| 1417 |
(let ((tail (cdr lis))) |
| 1418 |
(set-cdr! lis ans) |
| 1419 |
(lp tail lis))))) |
| 1420 |
|
| 1421 |
;;; Lists-as-sets |
| 1422 |
;;;;;;;;;;;;;;;;; |
| 1423 |
|
| 1424 |
;;; This is carefully tuned code; do not modify casually. |
| 1425 |
;;; - It is careful to share storage when possible; |
| 1426 |
;;; - Side-effecting code tries not to perform redundant writes. |
| 1427 |
;;; - It tries to avoid linear-time scans in special cases where constant-time |
| 1428 |
;;; computations can be performed. |
| 1429 |
;;; - It relies on similar properties from the other list-lib procs it calls. |
| 1430 |
;;; For example, it uses the fact that the implementations of MEMBER and |
| 1431 |
;;; FILTER in this source code share longest common tails between args |
| 1432 |
;;; and results to get structure sharing in the lset procedures. |
| 1433 |
|
| 1434 |
(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) |
| 1435 |
|
| 1436 |
(define (lset<= = . lists) |
| 1437 |
(check-arg procedure? = lset<=) |
| 1438 |
(or (not (pair? lists)) ; 0-ary case |
| 1439 |
(let lp ((s1 (car lists)) (rest (cdr lists))) |
| 1440 |
(or (not (pair? rest)) |
| 1441 |
(let ((s2 (car rest)) (rest (cdr rest))) |
| 1442 |
(and (or (eq? s2 s1) ; Fast path |
| 1443 |
(%lset2<= = s1 s2)) ; Real test |
| 1444 |
(lp s2 rest))))))) |
| 1445 |
|
| 1446 |
(define (lset= = . lists) |
| 1447 |
(check-arg procedure? = lset=) |
| 1448 |
(or (not (pair? lists)) ; 0-ary case |
| 1449 |
(let lp ((s1 (car lists)) (rest (cdr lists))) |
| 1450 |
(or (not (pair? rest)) |
| 1451 |
(let ((s2 (car rest)) |
| 1452 |
(rest (cdr rest))) |
| 1453 |
(and (or (eq? s1 s2) ; Fast path |
| 1454 |
(and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test |
| 1455 |
(lp s2 rest))))))) |
| 1456 |
|
| 1457 |
|
| 1458 |
(define (lset-adjoin = lis . elts) |
| 1459 |
(check-arg procedure? = lset-adjoin) |
| 1460 |
(fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) |
| 1461 |
lis elts)) |
| 1462 |
|
| 1463 |
|
| 1464 |
(define (lset-union = . lists) |
| 1465 |
(check-arg procedure? = lset-union) |
| 1466 |
(reduce (lambda (lis ans) ; Compute ANS + LIS. |
| 1467 |
(cond ((null? lis) ans) ; Don't copy any lists |
| 1468 |
((null? ans) lis) ; if we don't have to. |
| 1469 |
((eq? lis ans) ans) |
| 1470 |
(else |
| 1471 |
(fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) |
| 1472 |
ans |
| 1473 |
(cons elt ans))) |
| 1474 |
ans lis)))) |
| 1475 |
'() lists)) |
| 1476 |
|
| 1477 |
(define (lset-union! = . lists) |
| 1478 |
(check-arg procedure? = lset-union!) |
| 1479 |
(reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. |
| 1480 |
(cond ((null? lis) ans) ; Don't copy any lists |
| 1481 |
((null? ans) lis) ; if we don't have to. |
| 1482 |
((eq? lis ans) ans) |
| 1483 |
(else |
| 1484 |
(pair-fold (lambda (pair ans) |
| 1485 |
(let ((elt (car pair))) |
| 1486 |
(if (any (lambda (x) (= x elt)) ans) |
| 1487 |
ans |
| 1488 |
(begin (set-cdr! pair ans) pair)))) |
| 1489 |
ans lis)))) |
| 1490 |
'() lists)) |
| 1491 |
|
| 1492 |
|
| 1493 |
(define (lset-intersection = lis1 . lists) |
| 1494 |
(check-arg procedure? = lset-intersection) |
| 1495 |
(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. |
| 1496 |
(cond ((any null-list? lists) '()) ; Short cut |
| 1497 |
((null? lists) lis1) ; Short cut |
| 1498 |
(else (filter (lambda (x) |
| 1499 |
(every (lambda (lis) (member x lis =)) lists)) |
| 1500 |
lis1))))) |
| 1501 |
|
| 1502 |
(define (lset-intersection! = lis1 . lists) |
| 1503 |
(check-arg procedure? = lset-intersection!) |
| 1504 |
(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. |
| 1505 |
(cond ((any null-list? lists) '()) ; Short cut |
| 1506 |
((null? lists) lis1) ; Short cut |
| 1507 |
(else (filter! (lambda (x) |
| 1508 |
(every (lambda (lis) (member x lis =)) lists)) |
| 1509 |
lis1))))) |
| 1510 |
|
| 1511 |
|
| 1512 |
(define (lset-difference = lis1 . lists) |
| 1513 |
(check-arg procedure? = lset-difference) |
| 1514 |
(let ((lists (filter pair? lists))) ; Throw out empty lists. |
| 1515 |
(cond ((null? lists) lis1) ; Short cut |
| 1516 |
((memq lis1 lists) '()) ; Short cut |
| 1517 |
(else (filter (lambda (x) |
| 1518 |
(every (lambda (lis) (not (member x lis =))) |
| 1519 |
lists)) |
| 1520 |
lis1))))) |
| 1521 |
|
| 1522 |
(define (lset-difference! = lis1 . lists) |
| 1523 |
(check-arg procedure? = lset-difference!) |
| 1524 |
(let ((lists (filter pair? lists))) ; Throw out empty lists. |
| 1525 |
(cond ((null? lists) lis1) ; Short cut |
| 1526 |
((memq lis1 lists) '()) ; Short cut |
| 1527 |
(else (filter! (lambda (x) |
| 1528 |
(every (lambda (lis) (not (member x lis =))) |
| 1529 |
lists)) |
| 1530 |
lis1))))) |
| 1531 |
|
| 1532 |
|
| 1533 |
(define (lset-xor = . lists) |
| 1534 |
(check-arg procedure? = lset-xor) |
| 1535 |
(reduce (lambda (b a) ; Compute A xor B: |
| 1536 |
;; Note that this code relies on the constant-time |
| 1537 |
;; short-cuts provided by LSET-DIFF+INTERSECTION, |
| 1538 |
;; LSET-DIFFERENCE & APPEND to provide constant-time short |
| 1539 |
;; cuts for the cases A = (), B = (), and A eq? B. It takes |
| 1540 |
;; a careful case analysis to see it, but it's carefully |
| 1541 |
;; built in. |
| 1542 |
|
| 1543 |
;; Compute a-b and a^b, then compute b-(a^b) and |
| 1544 |
;; cons it onto the front of a-b. |
| 1545 |
(receive (a-b a-int-b) (lset-diff+intersection = a b) |
| 1546 |
(cond ((null? a-b) (lset-difference = b a)) |
| 1547 |
((null? a-int-b) (append b a)) |
| 1548 |
(else (fold (lambda (xb ans) |
| 1549 |
(if (member xb a-int-b =) ans (cons xb ans))) |
| 1550 |
a-b |
| 1551 |
b))))) |
| 1552 |
'() lists)) |
| 1553 |
|
| 1554 |
|
| 1555 |
(define (lset-xor! = . lists) |
| 1556 |
(check-arg procedure? = lset-xor!) |
| 1557 |
(reduce (lambda (b a) ; Compute A xor B: |
| 1558 |
;; Note that this code relies on the constant-time |
| 1559 |
;; short-cuts provided by LSET-DIFF+INTERSECTION, |
| 1560 |
;; LSET-DIFFERENCE & APPEND to provide constant-time short |
| 1561 |
;; cuts for the cases A = (), B = (), and A eq? B. It takes |
| 1562 |
;; a careful case analysis to see it, but it's carefully |
| 1563 |
;; built in. |
| 1564 |
|
| 1565 |
;; Compute a-b and a^b, then compute b-(a^b) and |
| 1566 |
;; cons it onto the front of a-b. |
| 1567 |
(receive (a-b a-int-b) (lset-diff+intersection! = a b) |
| 1568 |
(cond ((null? a-b) (lset-difference! = b a)) |
| 1569 |
((null? a-int-b) (append! b a)) |
| 1570 |
(else (pair-fold (lambda (b-pair ans) |
| 1571 |
(if (member (car b-pair) a-int-b =) ans |
| 1572 |
(begin (set-cdr! b-pair ans) b-pair))) |
| 1573 |
a-b |
| 1574 |
b))))) |
| 1575 |
'() lists)) |
| 1576 |
|
| 1577 |
|
| 1578 |
(define (lset-diff+intersection = lis1 . lists) |
| 1579 |
(check-arg procedure? = lset-diff+intersection) |
| 1580 |
(cond ((every null-list? lists) (values lis1 '())) ; Short cut |
| 1581 |
((memq lis1 lists) (values '() lis1)) ; Short cut |
| 1582 |
(else (partition (lambda (elt) |
| 1583 |
(not (any (lambda (lis) (member elt lis =)) |
| 1584 |
lists))) |
| 1585 |
lis1)))) |
| 1586 |
|
| 1587 |
(define (lset-diff+intersection! = lis1 . lists) |
| 1588 |
(check-arg procedure? = lset-diff+intersection!) |
| 1589 |
(cond ((every null-list? lists) (values lis1 '())) ; Short cut |
| 1590 |
((memq lis1 lists) (values '() lis1)) ; Short cut |
| 1591 |
(else (partition! (lambda (elt) |
| 1592 |
(not (any (lambda (lis) (member elt lis =)) |
| 1593 |
lists))) |
| 1594 |
lis1)))) |
