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