Artifact e708e42538d8345fed352642b571d7cff9669951:
- File srfi/s1/lists.sls — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 41735)
0000: 23 21 72 36 72 73 0a 0a 3b 3b 20 43 6f 70 79 72 #!r6rs..;; Copyr 0010: 69 67 68 74 20 28 63 29 20 31 39 39 38 2c 20 31 ight (c) 1998, 1 0020: 39 39 39 20 62 79 20 4f 6c 69 6e 20 53 68 69 76 999 by Olin Shiv 0030: 65 72 73 2e 20 59 6f 75 20 6d 61 79 20 64 6f 20 ers. You may do 0040: 61 73 20 79 6f 75 20 70 6c 65 61 73 65 20 77 69 as you please wi 0050: 74 68 0a 3b 3b 20 74 68 69 73 20 63 6f 64 65 20 th.;; this code 0060: 61 73 20 6c 6f 6e 67 20 61 73 20 79 6f 75 20 64 as long as you d 0070: 6f 20 6e 6f 74 20 72 65 6d 6f 76 65 20 74 68 69 o not remove thi 0080: 73 20 63 6f 70 79 72 69 67 68 74 20 6e 6f 74 69 s copyright noti 0090: 63 65 20 6f 72 0a 3b 3b 20 68 6f 6c 64 20 6d 65 ce or.;; hold me 00a0: 20 6c 69 61 62 6c 65 20 66 6f 72 20 69 74 73 20 liable for its 00b0: 75 73 65 2e 20 50 6c 65 61 73 65 20 73 65 6e 64 use. Please send 00c0: 20 62 75 67 20 72 65 70 6f 72 74 73 20 74 6f 20 bug reports to 00d0: 73 68 69 76 65 72 73 40 61 69 2e 6d 69 74 2e 65 shivers@ai.mit.e 00e0: 64 75 2e 0a 3b 3b 20 20 20 20 20 2d 4f 6c 69 6e du..;; -Olin 00f0: 0a 0a 3b 3b 20 49 6b 61 72 75 73 20 70 6f 72 74 ..;; Ikarus port 0100: 69 6e 67 20 62 65 67 75 6e 20 62 79 20 41 62 64 ing begun by Abd 0110: 75 6c 61 7a 69 7a 20 47 68 75 6c 6f 75 6d 2c 20 ulaziz Ghuloum, 0120: 0a 3b 3b 20 61 6e 64 20 63 6f 6e 74 69 6e 75 65 .;; and continue 0130: 64 20 62 79 20 44 65 72 69 63 6b 20 45 64 64 69 d by Derick Eddi 0140: 6e 67 74 6f 6e 2e 0a 0a 28 6c 69 62 72 61 72 79 ngton...(library 0150: 20 28 73 72 66 69 20 73 31 20 6c 69 73 74 73 29 (srfi s1 lists) 0160: 0a 20 20 28 65 78 70 6f 72 74 0a 20 20 20 78 63 . (export. xc 0170: 6f 6e 73 20 6d 61 6b 65 2d 6c 69 73 74 20 6c 69 ons make-list li 0180: 73 74 2d 74 61 62 75 6c 61 74 65 20 6c 69 73 74 st-tabulate list 0190: 2d 63 6f 70 79 20 0a 20 20 20 70 72 6f 70 65 72 -copy . proper 01a0: 2d 6c 69 73 74 3f 20 63 69 72 63 75 6c 61 72 2d -list? circular- 01b0: 6c 69 73 74 3f 20 64 6f 74 74 65 64 2d 6c 69 73 list? dotted-lis 01c0: 74 3f 20 6e 6f 74 2d 70 61 69 72 3f 20 6e 75 6c t? not-pair? nul 01d0: 6c 2d 6c 69 73 74 3f 20 6c 69 73 74 3d 0a 20 20 l-list? list=. 01e0: 20 63 69 72 63 75 6c 61 72 2d 6c 69 73 74 20 6c circular-list l 01f0: 65 6e 67 74 68 2b 0a 20 20 20 69 6f 74 61 0a 20 ength+. iota. 0200: 20 20 66 69 72 73 74 20 73 65 63 6f 6e 64 20 74 first second t 0210: 68 69 72 64 20 66 6f 75 72 74 68 20 66 69 66 74 hird fourth fift 0220: 68 20 73 69 78 74 68 20 73 65 76 65 6e 74 68 20 h sixth seventh 0230: 65 69 67 68 74 68 20 6e 69 6e 74 68 20 74 65 6e eighth ninth ten 0240: 74 68 0a 20 20 20 63 61 72 2b 63 64 72 0a 20 20 th. car+cdr. 0250: 20 74 61 6b 65 20 20 20 20 20 20 20 64 72 6f 70 take drop 0260: 20 20 20 20 20 20 20 0a 20 20 20 74 61 6b 65 2d . take- 0270: 72 69 67 68 74 20 64 72 6f 70 2d 72 69 67 68 74 right drop-right 0280: 20 0a 20 20 20 74 61 6b 65 21 20 20 20 20 20 20 . take! 0290: 64 72 6f 70 2d 72 69 67 68 74 21 0a 20 20 20 73 drop-right!. s 02a0: 70 6c 69 74 2d 61 74 20 20 20 73 70 6c 69 74 2d plit-at split- 02b0: 61 74 21 0a 20 20 20 6c 61 73 74 20 6c 61 73 74 at!. last last 02c0: 2d 70 61 69 72 0a 20 20 20 7a 69 70 20 75 6e 7a -pair. zip unz 02d0: 69 70 31 20 75 6e 7a 69 70 32 20 75 6e 7a 69 70 ip1 unzip2 unzip 02e0: 33 20 75 6e 7a 69 70 34 20 75 6e 7a 69 70 35 0a 3 unzip4 unzip5. 02f0: 20 20 20 63 6f 75 6e 74 0a 20 20 20 61 70 70 65 count. appe 0300: 6e 64 21 20 61 70 70 65 6e 64 2d 72 65 76 65 72 nd! append-rever 0310: 73 65 20 61 70 70 65 6e 64 2d 72 65 76 65 72 73 se append-revers 0320: 65 21 20 63 6f 6e 63 61 74 65 6e 61 74 65 20 63 e! concatenate c 0330: 6f 6e 63 61 74 65 6e 61 74 65 21 20 0a 20 20 20 oncatenate! . 0340: 75 6e 66 6f 6c 64 20 20 20 20 20 20 20 66 6f 6c unfold fol 0350: 64 20 20 20 20 20 20 20 70 61 69 72 2d 66 6f 6c d pair-fol 0360: 64 20 20 20 20 20 20 20 72 65 64 75 63 65 0a 20 d reduce. 0370: 20 20 75 6e 66 6f 6c 64 2d 72 69 67 68 74 20 20 unfold-right 0380: 20 20 20 20 20 20 20 20 20 20 70 61 69 72 2d 66 pair-f 0390: 6f 6c 64 2d 72 69 67 68 74 20 72 65 64 75 63 65 old-right reduce 03a0: 2d 72 69 67 68 74 0a 20 20 20 61 70 70 65 6e 64 -right. append 03b0: 2d 6d 61 70 20 61 70 70 65 6e 64 2d 6d 61 70 21 -map append-map! 03c0: 20 6d 61 70 21 20 70 61 69 72 2d 66 6f 72 2d 65 map! pair-for-e 03d0: 61 63 68 20 66 69 6c 74 65 72 2d 6d 61 70 20 6d ach filter-map m 03e0: 61 70 2d 69 6e 2d 6f 72 64 65 72 0a 20 20 20 66 ap-in-order. f 03f0: 69 6c 74 65 72 21 20 70 61 72 74 69 74 69 6f 6e ilter! partition 0400: 21 20 72 65 6d 6f 76 65 21 20 0a 20 20 20 66 69 ! remove! . fi 0410: 6e 64 2d 74 61 69 6c 20 61 6e 79 20 65 76 65 72 nd-tail any ever 0420: 79 20 6c 69 73 74 2d 69 6e 64 65 78 0a 20 20 20 y list-index. 0430: 74 61 6b 65 2d 77 68 69 6c 65 20 64 72 6f 70 2d take-while drop- 0440: 77 68 69 6c 65 20 74 61 6b 65 2d 77 68 69 6c 65 while take-while 0450: 21 0a 20 20 20 73 70 61 6e 20 62 72 65 61 6b 20 !. span break 0460: 73 70 61 6e 21 20 62 72 65 61 6b 21 0a 20 20 20 span! break!. 0470: 64 65 6c 65 74 65 20 64 65 6c 65 74 65 21 0a 20 delete delete!. 0480: 20 20 61 6c 69 73 74 2d 63 6f 6e 73 20 61 6c 69 alist-cons ali 0490: 73 74 2d 63 6f 70 79 0a 20 20 20 64 65 6c 65 74 st-copy. delet 04a0: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 64 65 6c e-duplicates del 04b0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 21 0a ete-duplicates!. 04c0: 20 20 20 61 6c 69 73 74 2d 64 65 6c 65 74 65 20 alist-delete 04d0: 61 6c 69 73 74 2d 64 65 6c 65 74 65 21 0a 20 20 alist-delete!. 04e0: 20 72 65 76 65 72 73 65 21 20 0a 20 20 20 6c 73 reverse! . ls 04f0: 65 74 3c 3d 20 6c 73 65 74 3d 20 6c 73 65 74 2d et<= lset= lset- 0500: 61 64 6a 6f 69 6e 20 20 0a 20 20 20 6c 73 65 74 adjoin . lset 0510: 2d 75 6e 69 6f 6e 20 20 6c 73 65 74 2d 69 6e 74 -union lset-int 0520: 65 72 73 65 63 74 69 6f 6e 20 20 6c 73 65 74 2d ersection lset- 0530: 64 69 66 66 65 72 65 6e 63 65 20 20 6c 73 65 74 difference lset 0540: 2d 78 6f 72 20 20 0a 20 20 20 6c 73 65 74 2d 64 -xor . lset-d 0550: 69 66 66 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e iff+intersection 0560: 0a 20 20 20 6c 73 65 74 2d 75 6e 69 6f 6e 21 20 . lset-union! 0570: 6c 73 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f lset-intersectio 0580: 6e 21 20 6c 73 65 74 2d 64 69 66 66 65 72 65 6e n! lset-differen 0590: 63 65 21 20 6c 73 65 74 2d 78 6f 72 21 0a 20 20 ce! lset-xor!. 05a0: 20 6c 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 lset-diff+inter 05b0: 73 65 63 74 69 6f 6e 21 0a 20 20 20 3b 3b 20 72 section!. ;; r 05c0: 65 2d 65 78 70 6f 72 74 65 64 3a 0a 20 20 20 61 e-exported:. a 05d0: 70 70 65 6e 64 20 61 73 73 71 20 61 73 73 76 20 ppend assq assv 05e0: 63 61 61 61 61 72 20 63 61 61 61 64 72 20 63 61 caaaar caaadr ca 05f0: 61 61 72 20 63 61 61 64 61 72 20 63 61 61 64 64 aar caadar caadd 0600: 72 0a 20 20 20 63 61 61 64 72 20 63 61 61 72 20 r. caadr caar 0610: 63 61 64 61 61 72 20 63 61 64 61 64 72 20 63 61 cadaar cadadr ca 0620: 64 61 72 20 63 61 64 64 61 72 20 63 61 64 64 64 dar caddar caddd 0630: 72 20 63 61 64 64 72 20 63 61 64 72 0a 20 20 20 r caddr cadr. 0640: 63 61 72 20 63 64 61 61 61 72 20 63 64 61 61 64 car cdaaar cdaad 0650: 72 20 63 64 61 61 72 20 63 64 61 64 61 72 20 63 r cdaar cdadar c 0660: 64 61 64 64 72 20 63 64 61 64 72 20 63 64 61 72 daddr cdadr cdar 0670: 20 63 64 64 61 61 72 0a 20 20 20 63 64 64 61 64 cddaar. cddad 0680: 72 20 63 64 64 61 72 20 63 64 64 64 61 72 20 63 r cddar cdddar c 0690: 64 64 64 64 72 20 63 64 64 64 72 20 63 64 64 72 ddddr cdddr cddr 06a0: 20 63 64 72 20 63 6f 6e 73 20 63 6f 6e 73 2a 0a cdr cons cons*. 06b0: 20 20 20 6c 65 6e 67 74 68 20 6c 69 73 74 20 6c length list l 06c0: 69 73 74 2d 72 65 66 20 6d 65 6d 71 20 6d 65 6d ist-ref memq mem 06d0: 76 20 6e 75 6c 6c 3f 20 70 61 69 72 3f 0a 20 20 v null? pair?. 06e0: 20 72 65 76 65 72 73 65 20 73 65 74 2d 63 61 72 reverse set-car 06f0: 21 20 73 65 74 2d 63 64 72 21 0a 20 20 20 3b 3b ! set-cdr!. ;; 0700: 20 64 69 66 66 65 72 65 6e 74 20 74 68 61 6e 20 different than 0710: 52 36 52 53 3a 0a 20 20 20 61 73 73 6f 63 20 66 R6RS:. assoc f 0720: 69 6c 74 65 72 20 66 69 6e 64 20 66 6f 6c 64 2d ilter find fold- 0730: 72 69 67 68 74 20 66 6f 72 2d 65 61 63 68 20 6d right for-each m 0740: 61 70 20 6d 65 6d 62 65 72 20 70 61 72 74 69 74 ap member partit 0750: 69 6f 6e 20 72 65 6d 6f 76 65 29 0a 20 20 28 69 ion remove). (i 0760: 6d 70 6f 72 74 20 0a 20 20 20 28 65 78 63 65 70 mport . (excep 0770: 74 20 28 72 6e 72 73 29 0a 20 20 20 20 20 20 20 t (rnrs). 0780: 20 20 20 20 61 73 73 6f 63 20 65 72 72 6f 72 20 assoc error 0790: 66 69 6c 74 65 72 20 66 69 6e 64 20 66 6f 6c 64 filter find fold 07a0: 2d 72 69 67 68 74 0a 20 20 20 20 20 20 20 20 20 -right. 07b0: 20 20 66 6f 72 2d 65 61 63 68 20 6d 61 70 20 6d for-each map m 07c0: 65 6d 62 65 72 20 70 61 72 74 69 74 69 6f 6e 20 ember partition 07d0: 72 65 6d 6f 76 65 29 0a 20 20 20 28 72 6e 72 73 remove). (rnrs 07e0: 20 6d 75 74 61 62 6c 65 2d 70 61 69 72 73 29 29 mutable-pairs)) 07f0: 0a 0a 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 .. (define-synt 0800: 61 78 20 63 68 65 63 6b 2d 61 72 67 0a 20 20 20 ax check-arg. 0810: 20 28 6c 61 6d 62 64 61 20 28 73 74 78 29 0a 20 (lambda (stx). 0820: 20 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 73 (syntax-cas 0830: 65 20 73 74 78 20 28 29 0a 20 20 20 20 20 20 20 e stx (). 0840: 20 5b 28 5f 20 70 72 65 64 20 76 61 6c 20 63 61 [(_ pred val ca 0850: 6c 6c 65 72 29 0a 20 20 20 20 20 20 20 20 20 28 ller). ( 0860: 61 6e 64 20 28 69 64 65 6e 74 69 66 69 65 72 3f and (identifier? 0870: 20 23 27 76 61 6c 29 20 28 69 64 65 6e 74 69 66 #'val) (identif 0880: 69 65 72 3f 20 23 27 63 61 6c 6c 65 72 29 29 0a ier? #'caller)). 0890: 20 20 20 20 20 20 20 20 20 23 27 28 75 6e 6c 65 #'(unle 08a0: 73 73 20 28 70 72 65 64 20 76 61 6c 29 0a 20 20 ss (pred val). 08b0: 20 20 20 20 20 20 20 20 20 20 20 28 61 73 73 65 (asse 08c0: 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 rtion-violation 08d0: 27 63 61 6c 6c 65 72 20 22 63 68 65 63 6b 2d 61 'caller "check-a 08e0: 72 67 20 66 61 69 6c 65 64 22 20 76 61 6c 29 29 rg failed" val)) 08f0: 5d 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 ]))).. (define 0900: 28 65 72 72 6f 72 20 2e 20 61 72 67 73 29 0a 20 (error . args). 0910: 20 20 20 28 69 66 20 28 61 6e 64 20 28 3c 3d 20 (if (and (<= 0920: 32 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 29 2 (length args)) 0930: 20 28 73 79 6d 62 6f 6c 3f 20 28 63 61 72 20 61 (symbol? (car a 0940: 72 67 73 29 29 20 28 73 74 72 69 6e 67 3f 20 28 rgs)) (string? ( 0950: 63 61 64 72 20 61 72 67 73 29 29 29 0a 20 20 20 cadr args))). 0960: 20 20 20 20 20 28 61 70 70 6c 79 20 61 73 73 65 (apply asse 0970: 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 rtion-violation 0980: 61 72 67 73 29 0a 20 20 20 20 20 20 20 20 28 61 args). (a 0990: 70 70 6c 79 20 61 73 73 65 72 74 69 6f 6e 2d 76 pply assertion-v 09a0: 69 6f 6c 61 74 69 6f 6e 20 22 28 6c 69 62 72 61 iolation "(libra 09b0: 72 79 20 28 73 72 66 69 20 73 31 20 6c 69 73 74 ry (srfi s1 list 09c0: 73 29 29 22 0a 20 20 20 20 20 20 20 20 20 20 20 s))". 09d0: 20 20 20 20 22 6d 69 73 75 73 65 20 6f 66 20 65 "misuse of e 09e0: 72 72 6f 72 20 70 72 6f 63 65 64 75 72 65 22 20 rror procedure" 09f0: 61 72 67 73 29 29 29 0a 20 20 0a 20 20 3b 3b 20 args))). . ;; 0a00: 43 6f 6e 73 74 72 75 63 74 6f 72 73 0a 20 20 3b Constructors. ; 0a10: 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ; ;;;;;;;;;;;;;. 0a20: 0a 20 20 28 64 65 66 69 6e 65 20 28 78 63 6f 6e . (define (xcon 0a30: 73 20 64 20 61 29 20 28 63 6f 6e 73 20 61 20 64 s d a) (cons a d 0a40: 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6d )).. (define (m 0a50: 61 6b 65 2d 6c 69 73 74 20 6c 65 6e 20 2e 20 6d ake-list len . m 0a60: 61 79 62 65 2d 65 6c 74 29 0a 20 20 20 20 28 63 aybe-elt). (c 0a70: 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 heck-arg (lambda 0a80: 20 28 6e 29 20 28 61 6e 64 20 28 69 6e 74 65 67 (n) (and (integ 0a90: 65 72 3f 20 6e 29 20 28 3e 3d 20 6e 20 30 29 29 er? n) (>= n 0)) 0aa0: 29 20 6c 65 6e 20 6d 61 6b 65 2d 6c 69 73 74 29 ) len make-list) 0ab0: 0a 20 20 20 20 28 6c 65 74 20 28 28 65 6c 74 20 . (let ((elt 0ac0: 28 63 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 6d 61 (cond ((null? ma 0ad0: 79 62 65 2d 65 6c 74 29 20 23 66 29 20 3b 20 44 ybe-elt) #f) ; D 0ae0: 65 66 61 75 6c 74 20 76 61 6c 75 65 0a 20 20 20 efault value. 0af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b00: 20 20 28 28 6e 75 6c 6c 3f 20 28 63 64 72 20 6d ((null? (cdr m 0b10: 61 79 62 65 2d 65 6c 74 29 29 20 28 63 61 72 20 aybe-elt)) (car 0b20: 6d 61 79 62 65 2d 65 6c 74 29 29 0a 20 20 20 20 maybe-elt)). 0b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b40: 20 28 65 6c 73 65 20 28 65 72 72 6f 72 20 27 6d (else (error 'm 0b50: 61 6b 65 2d 6c 69 73 74 20 22 54 6f 6f 20 6d 61 ake-list "Too ma 0b60: 6e 79 20 61 72 67 75 6d 65 6e 74 73 22 0a 20 20 ny arguments". 0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b90: 28 63 6f 6e 73 20 6c 65 6e 20 6d 61 79 62 65 2d (cons len maybe- 0ba0: 65 6c 74 29 29 29 29 29 29 0a 20 20 20 20 20 20 elt)))))). 0bb0: 28 64 6f 20 28 28 69 20 6c 65 6e 20 28 2d 20 69 (do ((i len (- i 0bc0: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)). 0bd0: 28 61 6e 73 20 27 28 29 20 28 63 6f 6e 73 20 65 (ans '() (cons e 0be0: 6c 74 20 61 6e 73 29 29 29 0a 20 20 20 20 20 20 lt ans))). 0bf0: 20 20 20 20 28 28 3c 3d 20 69 20 30 29 20 61 6e ((<= i 0) an 0c00: 73 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 s)))).. (define 0c10: 20 28 6c 69 73 74 2d 74 61 62 75 6c 61 74 65 20 (list-tabulate 0c20: 6c 65 6e 20 70 72 6f 63 29 0a 20 20 20 20 28 63 len proc). (c 0c30: 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 heck-arg (lambda 0c40: 20 28 6e 29 20 28 61 6e 64 20 28 69 6e 74 65 67 (n) (and (integ 0c50: 65 72 3f 20 6e 29 20 28 3e 3d 20 6e 20 30 29 29 er? n) (>= n 0)) 0c60: 29 20 6c 65 6e 20 6c 69 73 74 2d 74 61 62 75 6c ) len list-tabul 0c70: 61 74 65 29 0a 20 20 20 20 28 63 68 65 63 6b 2d ate). (check- 0c80: 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 arg procedure? p 0c90: 72 6f 63 20 6c 69 73 74 2d 74 61 62 75 6c 61 74 roc list-tabulat 0ca0: 65 29 0a 20 20 20 20 28 64 6f 20 28 28 69 20 28 e). (do ((i ( 0cb0: 2d 20 6c 65 6e 20 31 29 20 28 2d 20 69 20 31 29 - len 1) (- i 1) 0cc0: 29 0a 20 20 20 20 20 20 20 20 20 28 61 6e 73 20 ). (ans 0cd0: 27 28 29 20 28 63 6f 6e 73 20 28 70 72 6f 63 20 '() (cons (proc 0ce0: 69 29 20 61 6e 73 29 29 29 0a 20 20 20 20 20 20 i) ans))). 0cf0: 20 20 28 28 3c 20 69 20 30 29 20 61 6e 73 29 29 ((< i 0) ans)) 0d00: 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 69 ).. (define (li 0d10: 73 74 2d 63 6f 70 79 20 6c 69 73 29 09 09 09 09 st-copy lis).... 0d20: 0a 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 20 . (let recur 0d30: 28 28 6c 69 73 20 6c 69 73 29 29 09 09 09 0a 20 ((lis lis)).... 0d40: 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 (if (pair? 0d50: 6c 69 73 29 09 09 09 09 0a 20 20 20 20 20 20 20 lis)..... 0d60: 20 20 20 28 63 6f 6e 73 20 28 63 61 72 20 6c 69 (cons (car li 0d70: 73 29 20 28 72 65 63 75 72 20 28 63 64 72 20 6c s) (recur (cdr l 0d80: 69 73 29 29 29 09 0a 20 20 20 20 20 20 20 20 20 is))).. 0d90: 20 6c 69 73 29 29 29 09 09 09 09 09 0a 0a 20 20 lis)))....... 0da0: 28 64 65 66 69 6e 65 20 69 6f 74 61 0a 20 20 20 (define iota. 0db0: 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 (case-lambda. 0dc0: 20 20 20 5b 28 63 6f 75 6e 74 29 20 28 69 6f 74 [(count) (iot 0dd0: 61 20 63 6f 75 6e 74 20 30 20 31 29 5d 0a 20 20 a count 0 1)]. 0de0: 20 20 20 5b 28 63 6f 75 6e 74 20 73 74 61 72 74 [(count start 0df0: 29 20 28 69 6f 74 61 20 63 6f 75 6e 74 20 73 74 ) (iota count st 0e00: 61 72 74 20 31 29 5d 0a 20 20 20 20 20 5b 28 63 art 1)]. [(c 0e10: 6f 75 6e 74 20 73 74 61 72 74 20 73 74 65 70 29 ount start step) 0e20: 0a 20 20 20 20 20 20 28 63 68 65 63 6b 2d 61 72 . (check-ar 0e30: 67 20 69 6e 74 65 67 65 72 3f 20 63 6f 75 6e 74 g integer? count 0e40: 20 69 6f 74 61 29 0a 20 20 20 20 20 20 28 69 66 iota). (if 0e50: 20 28 3c 20 63 6f 75 6e 74 20 30 29 20 28 65 72 (< count 0) (er 0e60: 72 6f 72 20 27 69 6f 74 61 20 22 4e 65 67 61 74 ror 'iota "Negat 0e70: 69 76 65 20 73 74 65 70 20 63 6f 75 6e 74 22 20 ive step count" 0e80: 63 6f 75 6e 74 29 29 0a 20 20 20 20 20 20 28 63 count)). (c 0e90: 68 65 63 6b 2d 61 72 67 20 6e 75 6d 62 65 72 3f heck-arg number? 0ea0: 20 73 74 61 72 74 20 69 6f 74 61 29 0a 20 20 20 start iota). 0eb0: 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 6e 75 (check-arg nu 0ec0: 6d 62 65 72 3f 20 73 74 65 70 20 69 6f 74 61 29 mber? step iota) 0ed0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6c 61 . (let ((la 0ee0: 73 74 2d 76 61 6c 20 28 2b 20 73 74 61 72 74 20 st-val (+ start 0ef0: 28 2a 20 28 2d 20 63 6f 75 6e 74 20 31 29 20 73 (* (- count 1) s 0f00: 74 65 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 tep)))). 0f10: 28 64 6f 20 28 28 63 6f 75 6e 74 20 63 6f 75 6e (do ((count coun 0f20: 74 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 0a 20 t (- count 1)). 0f30: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c (val 0f40: 20 6c 61 73 74 2d 76 61 6c 20 28 2d 20 76 61 6c last-val (- val 0f50: 20 73 74 65 70 29 29 0a 20 20 20 20 20 20 20 20 step)). 0f60: 20 20 20 20 20 28 61 6e 73 20 27 28 29 20 28 63 (ans '() (c 0f70: 6f 6e 73 20 76 61 6c 20 61 6e 73 29 29 29 0a 20 ons val ans))). 0f80: 20 20 20 20 20 20 20 20 20 20 20 28 28 3c 3d 20 ((<= 0f90: 63 6f 75 6e 74 20 30 29 20 20 61 6e 73 29 29 29 count 0) ans))) 0fa0: 5d 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 ])). . (define 0fb0: 20 28 63 69 72 63 75 6c 61 72 2d 6c 69 73 74 20 (circular-list 0fc0: 76 61 6c 31 20 2e 20 76 61 6c 73 29 0a 20 20 20 val1 . vals). 0fd0: 20 28 6c 65 74 20 28 28 61 6e 73 20 28 63 6f 6e (let ((ans (con 0fe0: 73 20 76 61 6c 31 20 76 61 6c 73 29 29 29 0a 20 s val1 vals))). 0ff0: 20 20 20 20 20 28 73 65 74 2d 63 64 72 21 20 28 (set-cdr! ( 1000: 6c 61 73 74 2d 70 61 69 72 20 61 6e 73 29 20 61 last-pair ans) a 1010: 6e 73 29 0a 20 20 20 20 20 20 61 6e 73 29 29 0a ns). ans)). 1020: 0a 20 20 28 64 65 66 69 6e 65 20 28 70 72 6f 70 . (define (prop 1030: 65 72 2d 6c 69 73 74 3f 20 78 29 0a 20 20 20 20 er-list? x). 1040: 28 6c 65 74 20 6c 70 20 28 28 78 20 78 29 20 28 (let lp ((x x) ( 1050: 6c 61 67 20 78 29 29 0a 20 20 20 20 20 20 28 69 lag x)). (i 1060: 66 20 28 70 61 69 72 3f 20 78 29 0a 20 20 20 20 f (pair? x). 1070: 20 20 20 20 20 20 28 6c 65 74 20 28 28 78 20 28 (let ((x ( 1080: 63 64 72 20 78 29 29 29 0a 20 20 20 20 20 20 20 cdr x))). 1090: 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 (if (pair? 10a0: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x). 10b0: 20 20 20 28 6c 65 74 20 28 28 78 20 20 20 28 63 (let ((x (c 10c0: 64 72 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 dr x)). 10d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la 10e0: 67 20 28 63 64 72 20 6c 61 67 29 29 29 0a 20 20 g (cdr lag))). 10f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1100: 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 3f 20 78 (and (not (eq? x 1110: 20 6c 61 67 29 29 20 28 6c 70 20 78 20 6c 61 67 lag)) (lp x lag 1120: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 1130: 20 20 20 20 28 6e 75 6c 6c 3f 20 78 29 29 29 0a (null? x))). 1140: 20 20 20 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f (null? 1150: 20 78 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e x)))).. (defin 1160: 65 20 28 64 6f 74 74 65 64 2d 6c 69 73 74 3f 20 e (dotted-list? 1170: 78 29 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 x). (let lp ( 1180: 28 78 20 78 29 20 28 6c 61 67 20 78 29 29 0a 20 (x x) (lag x)). 1190: 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 (if (pair? 11a0: 78 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 x). (le 11b0: 74 20 28 28 78 20 28 63 64 72 20 78 29 29 29 0a t ((x (cdr x))). 11c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 11d0: 28 70 61 69 72 3f 20 78 29 0a 20 20 20 20 20 20 (pair? x). 11e0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 11f0: 28 78 20 20 20 28 63 64 72 20 78 29 29 0a 20 20 (x (cdr x)). 1200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1210: 20 20 20 20 28 6c 61 67 20 28 63 64 72 20 6c 61 (lag (cdr la 1220: 67 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 g))). 1230: 20 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f 74 (and (not 1240: 20 28 65 71 3f 20 78 20 6c 61 67 29 29 20 28 6c (eq? x lag)) (l 1250: 70 20 78 20 6c 61 67 29 29 29 0a 20 20 20 20 20 p x lag))). 1260: 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 (not 1270: 28 6e 75 6c 6c 3f 20 78 29 29 29 29 0a 20 20 20 (null? x)))). 1280: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c (not (nul 1290: 6c 3f 20 78 29 29 29 29 29 0a 0a 20 20 28 64 65 l? x))))).. (de 12a0: 66 69 6e 65 20 28 63 69 72 63 75 6c 61 72 2d 6c fine (circular-l 12b0: 69 73 74 3f 20 78 29 0a 20 20 20 20 28 6c 65 74 ist? x). (let 12c0: 20 6c 70 20 28 28 78 20 78 29 20 28 6c 61 67 20 lp ((x x) (lag 12d0: 78 29 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 x)). (and ( 12e0: 70 61 69 72 3f 20 78 29 0a 20 20 20 20 20 20 20 pair? x). 12f0: 20 20 20 20 28 6c 65 74 20 28 28 78 20 28 63 64 (let ((x (cd 1300: 72 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 r x))). 1310: 20 20 20 20 28 61 6e 64 20 28 70 61 69 72 3f 20 (and (pair? 1320: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x). 1330: 20 20 20 20 20 28 6c 65 74 20 28 28 78 20 20 20 (let ((x 1340: 28 63 64 72 20 78 29 29 0a 20 20 20 20 20 20 20 (cdr x)). 1350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1360: 20 28 6c 61 67 20 28 63 64 72 20 6c 61 67 29 29 (lag (cdr lag)) 1370: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 1380: 20 20 20 20 20 20 28 6f 72 20 28 65 71 3f 20 78 (or (eq? x 1390: 20 6c 61 67 29 20 28 6c 70 20 78 20 6c 61 67 29 lag) (lp x lag) 13a0: 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 ))))))).. (defi 13b0: 6e 65 20 28 6e 6f 74 2d 70 61 69 72 3f 20 78 29 ne (not-pair? x) 13c0: 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 78 29 29 (not (pair? x)) 13d0: 29 09 3b 20 49 6e 6c 69 6e 65 20 6d 65 2e 0a 0a ).; Inline me... 13e0: 20 20 28 64 65 66 69 6e 65 20 28 6e 75 6c 6c 2d (define (null- 13f0: 6c 69 73 74 3f 20 6c 29 0a 20 20 20 20 28 63 6f list? l). (co 1400: 6e 64 20 28 28 70 61 69 72 3f 20 6c 29 20 23 66 nd ((pair? l) #f 1410: 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 ). ((nu 1420: 6c 6c 3f 20 6c 29 20 23 74 29 0a 20 20 20 20 20 ll? l) #t). 1430: 20 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 6f (else (erro 1440: 72 20 27 6e 75 6c 6c 2d 6c 69 73 74 3f 20 22 61 r 'null-list? "a 1450: 72 67 75 6d 65 6e 74 20 6f 75 74 20 6f 66 20 64 rgument out of d 1460: 6f 6d 61 69 6e 22 20 6c 29 29 29 29 0a 20 20 0a omain" l)))). . 1470: 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 69 73 74 . (define (list 1480: 3d 20 65 6c 74 3d 20 2e 20 6c 69 73 74 73 29 0a = elt= . lists). 1490: 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 6c (or (null? l 14a0: 69 73 74 73 29 20 3b 20 73 70 65 63 69 61 6c 20 ists) ; special 14b0: 63 61 73 65 0a 20 20 20 20 20 20 20 20 28 6c 65 case. (le 14c0: 74 20 6c 70 31 20 28 28 6c 69 73 74 2d 61 20 28 t lp1 ((list-a ( 14d0: 63 61 72 20 6c 69 73 74 73 29 29 20 28 6f 74 68 car lists)) (oth 14e0: 65 72 73 20 28 63 64 72 20 6c 69 73 74 73 29 29 ers (cdr lists)) 14f0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 ). (or 1500: 28 6e 75 6c 6c 3f 20 6f 74 68 65 72 73 29 0a 20 (null? others). 1510: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 1520: 74 20 28 28 6c 69 73 74 2d 62 2d 6f 72 69 67 20 t ((list-b-orig 1530: 28 63 61 72 20 6f 74 68 65 72 73 29 29 0a 20 20 (car others)). 1540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1550: 20 20 28 6f 74 68 65 72 73 20 20 20 20 20 20 28 (others ( 1560: 63 64 72 20 6f 74 68 65 72 73 29 29 29 0a 20 20 cdr others))). 1570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 1580: 66 20 28 65 71 3f 20 6c 69 73 74 2d 61 20 6c 69 f (eq? list-a li 1590: 73 74 2d 62 2d 6f 72 69 67 29 09 3b 20 45 51 3f st-b-orig).; EQ? 15a0: 20 3d 3e 20 4c 49 53 54 3d 0a 20 20 20 20 20 20 => LIST=. 15b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 15c0: 70 31 20 6c 69 73 74 2d 62 2d 6f 72 69 67 20 6f p1 list-b-orig o 15d0: 74 68 65 72 73 29 0a 20 20 20 20 20 20 20 20 20 thers). 15e0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let 15f0: 6c 70 32 20 28 28 6c 69 73 74 2d 61 20 6c 69 73 lp2 ((list-a lis 1600: 74 2d 61 29 20 28 6c 69 73 74 2d 62 20 6c 69 73 t-a) (list-b lis 1610: 74 2d 62 2d 6f 72 69 67 29 29 0a 20 20 20 20 20 t-b-orig)). 1620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1630: 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f (if (null-list? 1640: 20 6c 69 73 74 2d 61 29 0a 20 20 20 20 20 20 20 list-a). 1650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1660: 20 20 20 28 61 6e 64 20 28 6e 75 6c 6c 2d 6c 69 (and (null-li 1670: 73 74 3f 20 6c 69 73 74 2d 62 29 0a 20 20 20 20 st? list-b). 1680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1690: 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 31 20 (lp1 16a0: 6c 69 73 74 2d 62 2d 6f 72 69 67 20 6f 74 68 65 list-b-orig othe 16b0: 72 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 rs)). 16c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 16d0: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 2d 6c and (not (null-l 16e0: 69 73 74 3f 20 6c 69 73 74 2d 62 29 29 0a 20 20 ist? list-b)). 16f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1700: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el 1710: 74 3d 20 28 63 61 72 20 6c 69 73 74 2d 61 29 20 t= (car list-a) 1720: 28 63 61 72 20 6c 69 73 74 2d 62 29 29 0a 20 20 (car list-b)). 1730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1740: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 (lp 1750: 32 20 28 63 64 72 20 6c 69 73 74 2d 61 29 20 28 2 (cdr list-a) ( 1760: 63 64 72 20 6c 69 73 74 2d 62 29 29 29 29 29 29 cdr list-b)))))) 1770: 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 ))))).. (define 1780: 20 28 6c 65 6e 67 74 68 2b 20 78 29 09 09 09 3b (length+ x)...; 1790: 20 52 65 74 75 72 6e 73 20 23 66 20 69 66 20 58 Returns #f if X 17a0: 20 69 73 20 63 69 72 63 75 6c 61 72 2e 0a 20 20 is circular.. 17b0: 20 20 28 6c 65 74 20 6c 70 20 28 28 78 20 78 29 (let lp ((x x) 17c0: 20 28 6c 61 67 20 78 29 20 28 6c 65 6e 20 30 29 (lag x) (len 0) 17d0: 29 0a 20 20 20 20 20 20 28 69 66 20 28 70 61 69 ). (if (pai 17e0: 72 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 r? x). 17f0: 28 6c 65 74 20 28 28 78 20 28 63 64 72 20 78 29 (let ((x (cdr x) 1800: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 1810: 20 20 28 6c 65 6e 20 28 2b 20 6c 65 6e 20 31 29 (len (+ len 1) 1820: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). ( 1830: 69 66 20 28 70 61 69 72 3f 20 78 29 0a 20 20 20 if (pair? x). 1840: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 1850: 74 20 28 28 78 20 20 20 28 63 64 72 20 78 29 29 t ((x (cdr x)) 1860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 1870: 20 20 20 20 20 20 20 28 6c 61 67 20 28 63 64 72 (lag (cdr 1880: 20 6c 61 67 29 29 0a 20 20 20 20 20 20 20 20 20 lag)). 1890: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 18a0: 6e 20 28 2b 20 6c 65 6e 20 31 29 29 29 0a 20 20 n (+ len 1))). 18b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 18c0: 28 61 6e 64 20 28 6e 6f 74 20 28 65 71 3f 20 78 (and (not (eq? x 18d0: 20 6c 61 67 29 29 20 28 6c 70 20 78 20 6c 61 67 lag)) (lp x lag 18e0: 20 6c 65 6e 29 29 29 0a 20 20 20 20 20 20 20 20 len))). 18f0: 20 20 20 20 20 20 20 20 6c 65 6e 29 29 0a 20 20 len)). 1900: 20 20 20 20 20 20 20 20 6c 65 6e 29 29 29 0a 0a len))).. 1910: 20 20 28 64 65 66 69 6e 65 20 28 7a 69 70 20 6c (define (zip l 1920: 69 73 74 31 20 2e 20 6d 6f 72 65 2d 6c 69 73 74 ist1 . more-list 1930: 73 29 20 28 61 70 70 6c 79 20 6d 61 70 20 6c 69 s) (apply map li 1940: 73 74 20 6c 69 73 74 31 20 6d 6f 72 65 2d 6c 69 st list1 more-li 1950: 73 74 73 29 29 0a 0a 0a 20 20 3b 3b 20 53 65 6c sts))... ;; Sel 1960: 65 63 74 6f 72 73 0a 20 20 3b 3b 20 3b 3b 3b 3b ectors. ;; ;;;; 1970: 3b 3b 3b 3b 3b 3b 0a 0a 20 20 28 64 65 66 69 6e ;;;;;;.. (defin 1980: 65 20 66 69 72 73 74 20 20 63 61 72 29 0a 20 20 e first car). 1990: 28 64 65 66 69 6e 65 20 73 65 63 6f 6e 64 20 63 (define second c 19a0: 61 64 72 29 0a 20 20 28 64 65 66 69 6e 65 20 74 adr). (define t 19b0: 68 69 72 64 20 20 63 61 64 64 72 29 0a 20 20 28 hird caddr). ( 19c0: 64 65 66 69 6e 65 20 66 6f 75 72 74 68 20 63 61 define fourth ca 19d0: 64 64 64 72 29 0a 20 20 28 64 65 66 69 6e 65 20 dddr). (define 19e0: 28 66 69 66 74 68 20 20 20 78 29 20 28 63 61 72 (fifth x) (car 19f0: 20 20 20 20 28 63 64 64 64 64 72 20 78 29 29 29 (cddddr x))) 1a00: 0a 20 20 28 64 65 66 69 6e 65 20 28 73 69 78 74 . (define (sixt 1a10: 68 20 20 20 78 29 20 28 63 61 64 72 20 20 20 28 h x) (cadr ( 1a20: 63 64 64 64 64 72 20 78 29 29 29 0a 20 20 28 64 cddddr x))). (d 1a30: 65 66 69 6e 65 20 28 73 65 76 65 6e 74 68 20 78 efine (seventh x 1a40: 29 20 28 63 61 64 64 72 20 20 28 63 64 64 64 64 ) (caddr (cdddd 1a50: 72 20 78 29 29 29 0a 20 20 28 64 65 66 69 6e 65 r x))). (define 1a60: 20 28 65 69 67 68 74 68 20 20 78 29 20 28 63 61 (eighth x) (ca 1a70: 64 64 64 72 20 28 63 64 64 64 64 72 20 78 29 29 dddr (cddddr x)) 1a80: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 69 6e ). (define (nin 1a90: 74 68 20 20 20 78 29 20 28 63 61 72 20 20 28 63 th x) (car (c 1aa0: 64 64 64 64 72 20 28 63 64 64 64 64 72 20 78 29 ddddr (cddddr x) 1ab0: 29 29 29 0a 20 20 28 64 65 66 69 6e 65 20 28 74 ))). (define (t 1ac0: 65 6e 74 68 20 20 20 78 29 20 28 63 61 64 72 20 enth x) (cadr 1ad0: 28 63 64 64 64 64 72 20 28 63 64 64 64 64 72 20 (cddddr (cddddr 1ae0: 78 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 x)))).. (define 1af0: 20 28 63 61 72 2b 63 64 72 20 70 61 69 72 29 20 (car+cdr pair) 1b00: 28 76 61 6c 75 65 73 20 28 63 61 72 20 70 61 69 (values (car pai 1b10: 72 29 20 28 63 64 72 20 70 61 69 72 29 29 29 0a r) (cdr pair))). 1b20: 0a 20 20 28 64 65 66 69 6e 65 20 28 74 61 6b 65 . (define (take 1b30: 20 6c 69 73 20 6b 29 0a 20 20 20 20 28 63 68 65 lis k). (che 1b40: 63 6b 2d 61 72 67 20 69 6e 74 65 67 65 72 3f 20 ck-arg integer? 1b50: 6b 20 74 61 6b 65 29 0a 20 20 20 20 28 6c 65 74 k take). (let 1b60: 20 72 65 63 75 72 20 28 28 6c 69 73 20 6c 69 73 recur ((lis lis 1b70: 29 20 28 6b 20 6b 29 29 0a 20 20 20 20 20 20 28 ) (k k)). ( 1b80: 69 66 20 28 7a 65 72 6f 3f 20 6b 29 20 27 28 29 if (zero? k) '() 1b90: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 . (cons 1ba0: 20 28 63 61 72 20 6c 69 73 29 0a 20 20 20 20 20 (car lis). 1bb0: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 63 75 (recu 1bc0: 72 20 28 63 64 72 20 6c 69 73 29 20 28 2d 20 6b r (cdr lis) (- k 1bd0: 20 31 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 1)))))).. (def 1be0: 69 6e 65 20 28 64 72 6f 70 20 6c 69 73 20 6b 29 ine (drop lis k) 1bf0: 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 . (check-arg 1c00: 69 6e 74 65 67 65 72 3f 20 6b 20 64 72 6f 70 29 integer? k drop) 1c10: 0a 20 20 20 20 28 6c 65 74 20 69 74 65 72 20 28 . (let iter ( 1c20: 28 6c 69 73 20 6c 69 73 29 20 28 6b 20 6b 29 29 (lis lis) (k k)) 1c30: 0a 20 20 20 20 20 20 28 69 66 20 28 7a 65 72 6f . (if (zero 1c40: 3f 20 6b 29 20 6c 69 73 20 28 69 74 65 72 20 28 ? k) lis (iter ( 1c50: 63 64 72 20 6c 69 73 29 20 28 2d 20 6b 20 31 29 cdr lis) (- k 1) 1c60: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 1c70: 28 74 61 6b 65 21 20 6c 69 73 20 6b 29 0a 20 20 (take! lis k). 1c80: 20 20 28 63 68 65 63 6b 2d 61 72 67 20 69 6e 74 (check-arg int 1c90: 65 67 65 72 3f 20 6b 20 74 61 6b 65 21 29 0a 20 eger? k take!). 1ca0: 20 20 20 28 69 66 20 28 7a 65 72 6f 3f 20 6b 29 (if (zero? k) 1cb0: 20 27 28 29 0a 20 20 20 20 20 20 20 20 28 62 65 '(). (be 1cc0: 67 69 6e 20 28 73 65 74 2d 63 64 72 21 20 28 64 gin (set-cdr! (d 1cd0: 72 6f 70 20 6c 69 73 20 28 2d 20 6b 20 31 29 29 rop lis (- k 1)) 1ce0: 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 20 20 '()). 1cf0: 20 20 20 20 20 6c 69 73 29 29 29 0a 0a 20 20 28 lis))).. ( 1d00: 64 65 66 69 6e 65 20 28 74 61 6b 65 2d 72 69 67 define (take-rig 1d10: 68 74 20 6c 69 73 20 6b 29 0a 20 20 20 20 28 63 ht lis k). (c 1d20: 68 65 63 6b 2d 61 72 67 20 69 6e 74 65 67 65 72 heck-arg integer 1d30: 3f 20 6b 20 74 61 6b 65 2d 72 69 67 68 74 29 0a ? k take-right). 1d40: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 61 (let lp ((la 1d50: 67 20 6c 69 73 29 20 20 28 6c 65 61 64 20 28 64 g lis) (lead (d 1d60: 72 6f 70 20 6c 69 73 20 6b 29 29 29 0a 20 20 20 rop lis k))). 1d70: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 6c 65 (if (pair? le 1d80: 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c ad). (l 1d90: 70 20 28 63 64 72 20 6c 61 67 29 20 28 63 64 72 p (cdr lag) (cdr 1da0: 20 6c 65 61 64 29 29 0a 20 20 20 20 20 20 20 20 lead)). 1db0: 20 20 6c 61 67 29 29 29 0a 0a 20 20 28 64 65 66 lag))).. (def 1dc0: 69 6e 65 20 28 64 72 6f 70 2d 72 69 67 68 74 20 ine (drop-right 1dd0: 6c 69 73 20 6b 29 0a 20 20 20 20 28 63 68 65 63 lis k). (chec 1de0: 6b 2d 61 72 67 20 69 6e 74 65 67 65 72 3f 20 6b k-arg integer? k 1df0: 20 64 72 6f 70 2d 72 69 67 68 74 29 0a 20 20 20 drop-right). 1e00: 20 28 6c 65 74 20 72 65 63 75 72 20 28 28 6c 61 (let recur ((la 1e10: 67 20 6c 69 73 29 20 28 6c 65 61 64 20 28 64 72 g lis) (lead (dr 1e20: 6f 70 20 6c 69 73 20 6b 29 29 29 0a 20 20 20 20 op lis k))). 1e30: 20 20 28 69 66 20 28 70 61 69 72 3f 20 6c 65 61 (if (pair? lea 1e40: 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f d). (co 1e50: 6e 73 20 28 63 61 72 20 6c 61 67 29 20 28 72 65 ns (car lag) (re 1e60: 63 75 72 20 28 63 64 72 20 6c 61 67 29 20 28 63 cur (cdr lag) (c 1e70: 64 72 20 6c 65 61 64 29 29 29 0a 20 20 20 20 20 dr lead))). 1e80: 20 20 20 20 20 27 28 29 29 29 29 0a 0a 20 20 28 '()))).. ( 1e90: 64 65 66 69 6e 65 20 28 64 72 6f 70 2d 72 69 67 define (drop-rig 1ea0: 68 74 21 20 6c 69 73 20 6b 29 0a 20 20 20 20 28 ht! lis k). ( 1eb0: 63 68 65 63 6b 2d 61 72 67 20 69 6e 74 65 67 65 check-arg intege 1ec0: 72 3f 20 6b 20 64 72 6f 70 2d 72 69 67 68 74 21 r? k drop-right! 1ed0: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 6c 65 61 ). (let ((lea 1ee0: 64 20 28 64 72 6f 70 20 6c 69 73 20 6b 29 29 29 d (drop lis k))) 1ef0: 0a 20 20 20 20 20 20 28 69 66 20 28 70 61 69 72 . (if (pair 1f00: 3f 20 6c 65 61 64 29 0a 0a 20 20 20 20 20 20 20 ? lead).. 1f10: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 61 67 (let lp ((lag 1f20: 20 6c 69 73 29 20 20 28 6c 65 61 64 20 28 63 64 lis) (lead (cd 1f30: 72 20 6c 65 61 64 29 29 29 09 3b 20 53 74 61 6e r lead))).; Stan 1f40: 64 61 72 64 20 63 61 73 65 0a 20 20 20 20 20 20 dard case. 1f50: 20 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f (if (pair? 1f60: 20 6c 65 61 64 29 0a 20 20 20 20 20 20 20 20 20 lead). 1f70: 20 20 20 20 20 20 20 28 6c 70 20 28 63 64 72 20 (lp (cdr 1f80: 6c 61 67 29 20 28 63 64 72 20 6c 65 61 64 29 29 lag) (cdr lead)) 1f90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 1fa0: 20 28 62 65 67 69 6e 20 28 73 65 74 2d 63 64 72 (begin (set-cdr 1fb0: 21 20 6c 61 67 20 27 28 29 29 0a 20 20 20 20 20 ! lag '()). 1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1fd0: 20 20 6c 69 73 29 29 29 0a 0a 20 20 20 20 20 20 lis))).. 1fe0: 20 20 20 20 27 28 29 29 29 29 09 3b 20 53 70 65 '()))).; Spe 1ff0: 63 69 61 6c 20 63 61 73 65 20 64 72 6f 70 70 69 cial case droppi 2000: 6e 67 20 65 76 65 72 79 74 68 69 6e 67 20 2d 2d ng everything -- 2010: 20 6e 6f 20 63 6f 6e 73 20 74 6f 20 73 69 64 65 no cons to side 2020: 2d 65 66 66 65 63 74 2e 0a 0a 20 20 28 64 65 66 -effect... (def 2030: 69 6e 65 2d 73 79 6e 74 61 78 20 72 65 63 65 69 ine-syntax recei 2040: 76 65 0a 20 20 20 20 28 73 79 6e 74 61 78 2d 72 ve. (syntax-r 2050: 75 6c 65 73 20 28 29 0a 20 20 20 20 20 20 5b 28 ules (). [( 2060: 5f 20 28 69 64 2a 20 2e 2e 2e 29 20 65 78 70 72 _ (id* ...) expr 2070: 20 62 6f 64 79 20 62 6f 64 79 2a 20 2e 2e 2e 29 body body* ...) 2080: 0a 20 20 20 20 20 20 20 28 6c 65 74 2d 76 61 6c . (let-val 2090: 75 65 73 20 28 5b 28 69 64 2a 20 2e 2e 2e 29 20 ues ([(id* ...) 20a0: 65 78 70 72 5d 29 20 62 6f 64 79 20 62 6f 64 79 expr]) body body 20b0: 2a 20 2e 2e 2e 29 5d 29 29 0a 0a 0a 20 20 28 64 * ...)]))... (d 20c0: 65 66 69 6e 65 20 28 73 70 6c 69 74 2d 61 74 20 efine (split-at 20d0: 78 20 6b 29 0a 20 20 20 20 28 63 68 65 63 6b 2d x k). (check- 20e0: 61 72 67 20 69 6e 74 65 67 65 72 3f 20 6b 20 73 arg integer? k s 20f0: 70 6c 69 74 2d 61 74 29 0a 20 20 20 20 28 6c 65 plit-at). (le 2100: 74 20 72 65 63 75 72 20 28 28 6c 69 73 20 78 29 t recur ((lis x) 2110: 20 28 6b 20 6b 29 29 0a 20 20 20 20 20 20 28 69 (k k)). (i 2120: 66 20 28 7a 65 72 6f 3f 20 6b 29 20 28 76 61 6c f (zero? k) (val 2130: 75 65 73 20 27 28 29 20 6c 69 73 29 0a 20 20 20 ues '() lis). 2140: 20 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 (receive 2150: 28 70 72 65 66 69 78 20 73 75 66 66 69 78 29 20 (prefix suffix) 2160: 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 29 (recur (cdr lis) 2170: 20 28 2d 20 6b 20 31 29 29 0a 20 20 20 20 20 20 (- k 1)). 2180: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 (va 2190: 6c 75 65 73 20 28 63 6f 6e 73 20 28 63 61 72 20 lues (cons (car 21a0: 6c 69 73 29 20 70 72 65 66 69 78 29 20 73 75 66 lis) prefix) suf 21b0: 66 69 78 29 29 29 29 29 0a 0a 20 20 28 64 65 66 fix))))).. (def 21c0: 69 6e 65 20 28 73 70 6c 69 74 2d 61 74 21 20 78 ine (split-at! x 21d0: 20 6b 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 k). (check-a 21e0: 72 67 20 69 6e 74 65 67 65 72 3f 20 6b 20 73 70 rg integer? k sp 21f0: 6c 69 74 2d 61 74 21 29 0a 20 20 20 20 28 69 66 lit-at!). (if 2200: 20 28 7a 65 72 6f 3f 20 6b 29 20 28 76 61 6c 75 (zero? k) (valu 2210: 65 73 20 27 28 29 20 78 29 0a 20 20 20 20 20 20 es '() x). 2220: 20 20 28 6c 65 74 2a 20 28 28 70 72 65 76 20 28 (let* ((prev ( 2230: 64 72 6f 70 20 78 20 28 2d 20 6b 20 31 29 29 29 drop x (- k 1))) 2240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2250: 28 73 75 66 66 69 78 20 28 63 64 72 20 70 72 65 (suffix (cdr pre 2260: 76 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 v))). ( 2270: 73 65 74 2d 63 64 72 21 20 70 72 65 76 20 27 28 set-cdr! prev '( 2280: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 76 61 )). (va 2290: 6c 75 65 73 20 78 20 73 75 66 66 69 78 29 29 29 lues x suffix))) 22a0: 29 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c )... (define (l 22b0: 61 73 74 20 6c 69 73 29 20 28 63 61 72 20 28 6c ast lis) (car (l 22c0: 61 73 74 2d 70 61 69 72 20 6c 69 73 29 29 29 0a ast-pair lis))). 22d0: 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 61 73 74 . (define (last 22e0: 2d 70 61 69 72 20 6c 69 73 29 0a 20 20 20 20 28 -pair lis). ( 22f0: 63 68 65 63 6b 2d 61 72 67 20 70 61 69 72 3f 20 check-arg pair? 2300: 6c 69 73 20 6c 61 73 74 2d 70 61 69 72 29 0a 20 lis last-pair). 2310: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 69 73 (let lp ((lis 2320: 20 6c 69 73 29 29 0a 20 20 20 20 20 20 28 6c 65 lis)). (le 2330: 74 20 28 28 74 61 69 6c 20 28 63 64 72 20 6c 69 t ((tail (cdr li 2340: 73 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 s))). (if 2350: 20 28 70 61 69 72 3f 20 74 61 69 6c 29 20 28 6c (pair? tail) (l 2360: 70 20 74 61 69 6c 29 20 6c 69 73 29 29 29 29 0a p tail) lis)))). 2370: 0a 0a 20 20 3b 3b 20 55 6e 7a 69 70 70 65 72 73 .. ;; Unzippers 2380: 20 2d 2d 20 31 20 74 68 72 6f 75 67 68 20 35 0a -- 1 through 5. 2390: 20 20 3b 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;; ;;;;;;;;;;; 23a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 23b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 23c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 23d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 23e0: 3b 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 75 6e ;.. (define (un 23f0: 7a 69 70 31 20 6c 69 73 29 20 28 6d 61 70 20 63 zip1 lis) (map c 2400: 61 72 20 6c 69 73 29 29 0a 0a 20 20 28 64 65 66 ar lis)).. (def 2410: 69 6e 65 20 28 75 6e 7a 69 70 32 20 6c 69 73 29 ine (unzip2 lis) 2420: 0a 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 20 . (let recur 2430: 28 28 6c 69 73 20 6c 69 73 29 29 0a 20 20 20 20 ((lis lis)). 2440: 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 (if (null-list 2450: 3f 20 6c 69 73 29 20 28 76 61 6c 75 65 73 20 6c ? lis) (values l 2460: 69 73 20 6c 69 73 29 09 3b 20 55 73 65 20 4e 4f is lis).; Use NO 2470: 54 2d 50 41 49 52 3f 20 74 6f 20 68 61 6e 64 6c T-PAIR? to handl 2480: 65 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 e. (let 2490: 20 28 28 65 6c 74 20 28 63 61 72 20 6c 69 73 29 ((elt (car lis) 24a0: 29 29 09 09 09 3b 20 64 6f 74 74 65 64 20 6c 69 ))...; dotted li 24b0: 73 74 73 2e 0a 20 20 20 20 20 20 20 20 20 20 20 sts.. 24c0: 20 28 72 65 63 65 69 76 65 20 28 61 20 62 29 20 (receive (a b) 24d0: 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 29 (recur (cdr lis) 24e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 24f0: 20 20 20 20 20 20 20 28 76 61 6c 75 65 73 20 28 (values ( 2500: 63 6f 6e 73 20 28 63 61 72 20 20 65 6c 74 29 20 cons (car elt) 2510: 61 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 a). 2520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2530: 28 63 6f 6e 73 20 28 63 61 64 72 20 65 6c 74 29 (cons (cadr elt) 2540: 20 62 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 b))))))).. (de 2550: 66 69 6e 65 20 28 75 6e 7a 69 70 33 20 6c 69 73 fine (unzip3 lis 2560: 29 0a 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 ). (let recur 2570: 20 28 28 6c 69 73 20 6c 69 73 29 29 0a 20 20 20 ((lis lis)). 2580: 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 (if (null-lis 2590: 74 3f 20 6c 69 73 29 20 28 76 61 6c 75 65 73 20 t? lis) (values 25a0: 6c 69 73 20 6c 69 73 20 6c 69 73 29 0a 20 20 20 lis lis lis). 25b0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 65 6c (let ((el 25c0: 74 20 28 63 61 72 20 6c 69 73 29 29 29 0a 20 20 t (car lis))). 25d0: 20 20 20 20 20 20 20 20 20 20 28 72 65 63 65 69 (recei 25e0: 76 65 20 28 61 20 62 20 63 29 20 28 72 65 63 75 ve (a b c) (recu 25f0: 72 20 28 63 64 72 20 6c 69 73 29 29 0a 20 20 20 r (cdr lis)). 2600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2610: 20 20 28 76 61 6c 75 65 73 20 28 63 6f 6e 73 20 (values (cons 2620: 28 63 61 72 20 20 20 65 6c 74 29 20 61 29 0a 20 (car elt) a). 2630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2640: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con 2650: 73 20 28 63 61 64 72 20 20 65 6c 74 29 20 62 29 s (cadr elt) b) 2660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c 2680: 6f 6e 73 20 28 63 61 64 64 72 20 65 6c 74 29 20 ons (caddr elt) 2690: 63 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 c))))))).. (def 26a0: 69 6e 65 20 28 75 6e 7a 69 70 34 20 6c 69 73 29 ine (unzip4 lis) 26b0: 0a 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 20 . (let recur 26c0: 28 28 6c 69 73 20 6c 69 73 29 29 0a 20 20 20 20 ((lis lis)). 26d0: 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 (if (null-list 26e0: 3f 20 6c 69 73 29 20 28 76 61 6c 75 65 73 20 6c ? lis) (values l 26f0: 69 73 20 6c 69 73 20 6c 69 73 20 6c 69 73 29 0a is lis lis lis). 2700: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 2710: 28 65 6c 74 20 28 63 61 72 20 6c 69 73 29 29 29 (elt (car lis))) 2720: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 . (re 2730: 63 65 69 76 65 20 28 61 20 62 20 63 20 64 29 20 ceive (a b c d) 2740: 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 29 (recur (cdr lis) 2750: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 2760: 20 20 20 20 20 20 20 28 76 61 6c 75 65 73 20 28 (values ( 2770: 63 6f 6e 73 20 28 63 61 72 20 20 20 20 65 6c 74 cons (car elt 2780: 29 20 61 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) a). 2790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27a0: 20 20 28 63 6f 6e 73 20 28 63 61 64 72 20 20 20 (cons (cadr 27b0: 65 6c 74 29 20 62 29 0a 20 20 20 20 20 20 20 20 elt) b). 27c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27d0: 20 20 20 20 20 28 63 6f 6e 73 20 28 63 61 64 64 (cons (cadd 27e0: 72 20 20 65 6c 74 29 20 63 29 0a 20 20 20 20 20 r elt) c). 27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2800: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 63 (cons (c 2810: 61 64 64 64 72 20 65 6c 74 29 20 64 29 29 29 29 adddr elt) d)))) 2820: 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ))).. (define ( 2830: 75 6e 7a 69 70 35 20 6c 69 73 29 0a 20 20 20 20 unzip5 lis). 2840: 28 6c 65 74 20 72 65 63 75 72 20 28 28 6c 69 73 (let recur ((lis 2850: 20 6c 69 73 29 29 0a 20 20 20 20 20 20 28 69 66 lis)). (if 2860: 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 (null-list? lis 2870: 29 20 28 76 61 6c 75 65 73 20 6c 69 73 20 6c 69 ) (values lis li 2880: 73 20 6c 69 73 20 6c 69 73 20 6c 69 73 29 0a 20 s lis lis lis). 2890: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let (( 28a0: 65 6c 74 20 28 63 61 72 20 6c 69 73 29 29 29 0a elt (car lis))). 28b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 63 (rec 28c0: 65 69 76 65 20 28 61 20 62 20 63 20 64 20 65 29 eive (a b c d e) 28d0: 20 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 (recur (cdr lis 28e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 28f0: 20 20 20 20 20 20 20 20 28 76 61 6c 75 65 73 20 (values 2900: 28 63 6f 6e 73 20 28 63 61 72 20 20 20 20 20 65 (cons (car e 2910: 6c 74 29 20 61 29 0a 20 20 20 20 20 20 20 20 20 lt) a). 2920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2930: 20 20 20 20 28 63 6f 6e 73 20 28 63 61 64 72 20 (cons (cadr 2940: 20 20 20 65 6c 74 29 20 62 29 0a 20 20 20 20 20 elt) b). 2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2960: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 63 (cons (c 2970: 61 64 64 72 20 20 20 65 6c 74 29 20 63 29 0a 20 addr elt) c). 2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2990: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con 29a0: 73 20 28 63 61 64 64 64 72 20 20 65 6c 74 29 20 s (cadddr elt) 29b0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d). 29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29d0: 28 63 6f 6e 73 20 28 63 61 72 20 28 63 64 64 64 (cons (car (cddd 29e0: 64 72 20 20 65 6c 74 29 29 20 65 29 29 29 29 29 dr elt)) e))))) 29f0: 29 29 0a 0a 0a 20 20 3b 3b 20 61 70 70 65 6e 64 ))... ;; append 2a00: 21 20 61 70 70 65 6e 64 2d 72 65 76 65 72 73 65 ! append-reverse 2a10: 20 61 70 70 65 6e 64 2d 72 65 76 65 72 73 65 21 append-reverse! 2a20: 20 63 6f 6e 63 61 74 65 6e 61 74 65 20 63 6f 6e concatenate con 2a30: 63 61 74 65 6e 61 74 65 21 0a 20 20 3b 3b 20 3b catenate!. ;; ; 2a40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 2a50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 2a60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 2a70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ;;;;;;;;;;;;;;;. 2a80: 0a 20 20 28 64 65 66 69 6e 65 20 28 61 70 70 65 . (define (appe 2a90: 6e 64 21 20 2e 20 6c 69 73 74 73 29 0a 20 20 20 nd! . lists). 2aa0: 20 3b 3b 20 46 69 72 73 74 2c 20 73 63 61 6e 20 ;; First, scan 2ab0: 74 68 72 6f 75 67 68 20 6c 69 73 74 73 20 6c 6f through lists lo 2ac0: 6f 6b 69 6e 67 20 66 6f 72 20 61 20 6e 6f 6e 2d oking for a non- 2ad0: 65 6d 70 74 79 20 6f 6e 65 2e 0a 20 20 20 20 28 empty one.. ( 2ae0: 6c 65 74 20 6c 70 20 28 28 6c 69 73 74 73 20 6c let lp ((lists l 2af0: 69 73 74 73 29 20 28 70 72 65 76 20 27 28 29 29 ists) (prev '()) 2b00: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ). (if (not 2b10: 20 28 70 61 69 72 3f 20 6c 69 73 74 73 29 29 20 (pair? lists)) 2b20: 70 72 65 76 0a 20 20 20 20 20 20 20 20 20 20 28 prev. ( 2b30: 6c 65 74 20 28 28 66 69 72 73 74 20 28 63 61 72 let ((first (car 2b40: 20 6c 69 73 74 73 29 29 0a 20 20 20 20 20 20 20 lists)). 2b50: 20 20 20 20 20 20 20 20 20 28 72 65 73 74 20 28 (rest ( 2b60: 63 64 72 20 6c 69 73 74 73 29 29 29 0a 20 20 20 cdr lists))). 2b70: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no 2b80: 74 20 28 70 61 69 72 3f 20 66 69 72 73 74 29 29 t (pair? first)) 2b90: 20 28 6c 70 20 72 65 73 74 20 66 69 72 73 74 29 (lp rest first) 2ba0: 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .. 2bb0: 20 20 3b 3b 20 4e 6f 77 2c 20 64 6f 20 74 68 65 ;; Now, do the 2bc0: 20 73 70 6c 69 63 69 6e 67 2e 0a 20 20 20 20 20 splicing.. 2bd0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let 2be0: 6c 70 32 20 28 28 74 61 69 6c 2d 63 6f 6e 73 20 lp2 ((tail-cons 2bf0: 28 6c 61 73 74 2d 70 61 69 72 20 66 69 72 73 74 (last-pair first 2c00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re 2c20: 73 74 20 72 65 73 74 29 29 0a 20 20 20 20 20 20 st rest)). 2c30: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 2c40: 28 70 61 69 72 3f 20 72 65 73 74 29 0a 20 20 20 (pair? rest). 2c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2c60: 20 20 20 28 6c 65 74 20 28 28 6e 65 78 74 20 28 (let ((next ( 2c70: 63 61 72 20 72 65 73 74 29 29 0a 20 20 20 20 20 car rest)). 2c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2c90: 20 20 20 20 20 20 20 28 72 65 73 74 20 28 63 64 (rest (cd 2ca0: 72 20 72 65 73 74 29 29 29 0a 20 20 20 20 20 20 r rest))). 2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2cc0: 20 20 28 73 65 74 2d 63 64 72 21 20 74 61 69 6c (set-cdr! tail 2cd0: 2d 63 6f 6e 73 20 6e 65 78 74 29 0a 20 20 20 20 -cons next). 2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2cf0: 20 20 20 20 28 6c 70 32 20 28 69 66 20 28 70 61 (lp2 (if (pa 2d00: 69 72 3f 20 6e 65 78 74 29 20 28 6c 61 73 74 2d ir? next) (last- 2d10: 70 61 69 72 20 6e 65 78 74 29 20 74 61 69 6c 2d pair next) tail- 2d20: 63 6f 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 cons). 2d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d40: 20 20 20 72 65 73 74 29 29 0a 20 20 20 20 20 20 rest)). 2d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d60: 66 69 72 73 74 29 29 29 29 29 29 29 0a 0a 20 20 first))))))).. 2d70: 28 64 65 66 69 6e 65 20 28 61 70 70 65 6e 64 2d (define (append- 2d80: 72 65 76 65 72 73 65 20 72 65 76 2d 68 65 61 64 reverse rev-head 2d90: 20 74 61 69 6c 29 0a 20 20 20 20 28 6c 65 74 20 tail). (let 2da0: 6c 70 20 28 28 72 65 76 2d 68 65 61 64 20 72 65 lp ((rev-head re 2db0: 76 2d 68 65 61 64 29 20 28 74 61 69 6c 20 74 61 v-head) (tail ta 2dc0: 69 6c 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 il)). (if ( 2dd0: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 72 65 76 2d 68 null-list? rev-h 2de0: 65 61 64 29 20 74 61 69 6c 0a 20 20 20 20 20 20 ead) tail. 2df0: 20 20 20 20 28 6c 70 20 28 63 64 72 20 72 65 76 (lp (cdr rev 2e00: 2d 68 65 61 64 29 20 28 63 6f 6e 73 20 28 63 61 -head) (cons (ca 2e10: 72 20 72 65 76 2d 68 65 61 64 29 20 74 61 69 6c r rev-head) tail 2e20: 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 ))))).. (define 2e30: 20 28 61 70 70 65 6e 64 2d 72 65 76 65 72 73 65 (append-reverse 2e40: 21 20 72 65 76 2d 68 65 61 64 20 74 61 69 6c 29 ! rev-head tail) 2e50: 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 72 . (let lp ((r 2e60: 65 76 2d 68 65 61 64 20 72 65 76 2d 68 65 61 64 ev-head rev-head 2e70: 29 20 28 74 61 69 6c 20 74 61 69 6c 29 29 0a 20 ) (tail tail)). 2e80: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c (if (null-l 2e90: 69 73 74 3f 20 72 65 76 2d 68 65 61 64 29 20 74 ist? rev-head) t 2ea0: 61 69 6c 0a 20 20 20 20 20 20 20 20 20 20 28 6c ail. (l 2eb0: 65 74 20 28 28 6e 65 78 74 2d 72 65 76 20 28 63 et ((next-rev (c 2ec0: 64 72 20 72 65 76 2d 68 65 61 64 29 29 29 0a 20 dr rev-head))). 2ed0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 2d (set- 2ee0: 63 64 72 21 20 72 65 76 2d 68 65 61 64 20 74 61 cdr! rev-head ta 2ef0: 69 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 il). 2f00: 28 6c 70 20 6e 65 78 74 2d 72 65 76 20 72 65 76 (lp next-rev rev 2f10: 2d 68 65 61 64 29 29 29 29 29 0a 0a 0a 20 20 28 -head)))))... ( 2f20: 64 65 66 69 6e 65 20 28 63 6f 6e 63 61 74 65 6e define (concaten 2f30: 61 74 65 20 20 6c 69 73 74 73 29 20 28 72 65 64 ate lists) (red 2f40: 75 63 65 2d 72 69 67 68 74 20 61 70 70 65 6e 64 uce-right append 2f50: 20 20 27 28 29 20 6c 69 73 74 73 29 29 0a 20 20 '() lists)). 2f60: 28 64 65 66 69 6e 65 20 28 63 6f 6e 63 61 74 65 (define (concate 2f70: 6e 61 74 65 21 20 6c 69 73 74 73 29 20 28 72 65 nate! lists) (re 2f80: 64 75 63 65 2d 72 69 67 68 74 20 61 70 70 65 6e duce-right appen 2f90: 64 21 20 27 28 29 20 6c 69 73 74 73 29 29 0a 0a d! '() lists)).. 2fa0: 20 20 3b 3b 20 46 6f 6c 64 2f 6d 61 70 20 69 6e ;; Fold/map in 2fb0: 74 65 72 6e 61 6c 20 75 74 69 6c 69 74 69 65 73 ternal utilities 2fc0: 0a 20 20 3b 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b . ;; ;;;;;;;;;; 2fd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 2fe0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 2ff0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 3000: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 3010: 3b 3b 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 25 ;;.. (define (% 3020: 63 64 72 73 20 6c 69 73 74 73 29 0a 20 20 20 20 cdrs lists). 3030: 28 63 61 6c 6c 2d 77 69 74 68 2d 63 75 72 72 65 (call-with-curre 3040: 6e 74 2d 63 6f 6e 74 69 6e 75 61 74 69 6f 6e 0a nt-continuation. 3050: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 62 (lambda (ab 3060: 6f 72 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 ort). (let 3070: 20 72 65 63 75 72 20 28 28 6c 69 73 74 73 20 6c recur ((lists l 3080: 69 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 ists)). 3090: 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 74 73 (if (pair? lists 30a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). ( 30b0: 6c 65 74 20 28 28 6c 69 73 20 28 63 61 72 20 6c let ((lis (car l 30c0: 69 73 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 ists))). 30d0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null 30e0: 2d 6c 69 73 74 3f 20 6c 69 73 29 20 28 61 62 6f -list? lis) (abo 30f0: 72 74 20 27 28 29 29 0a 20 20 20 20 20 20 20 20 rt '()). 3100: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons 3110: 20 28 63 64 72 20 6c 69 73 29 20 28 72 65 63 75 (cdr lis) (recu 3120: 72 20 28 63 64 72 20 6c 69 73 74 73 29 29 29 29 r (cdr lists)))) 3130: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 27 ). ' 3140: 28 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 ()))))).. (defi 3150: 6e 65 20 28 25 63 61 72 73 2b 20 6c 69 73 74 73 ne (%cars+ lists 3160: 20 6c 61 73 74 2d 65 6c 74 29 09 3b 20 28 61 70 last-elt).; (ap 3170: 70 65 6e 64 21 20 28 6d 61 70 20 63 61 72 20 6c pend! (map car l 3180: 69 73 74 73 29 20 28 6c 69 73 74 20 6c 61 73 74 ists) (list last 3190: 2d 65 6c 74 29 29 0a 20 20 20 20 28 6c 65 74 20 -elt)). (let 31a0: 72 65 63 75 72 20 28 28 6c 69 73 74 73 20 6c 69 recur ((lists li 31b0: 73 74 73 29 29 0a 20 20 20 20 20 20 28 69 66 20 sts)). (if 31c0: 28 70 61 69 72 3f 20 6c 69 73 74 73 29 20 28 63 (pair? lists) (c 31d0: 6f 6e 73 20 28 63 61 61 72 20 6c 69 73 74 73 29 ons (caar lists) 31e0: 20 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 (recur (cdr lis 31f0: 74 73 29 29 29 20 28 6c 69 73 74 20 6c 61 73 74 ts))) (list last 3200: 2d 65 6c 74 29 29 29 29 0a 0a 20 20 28 64 65 66 -elt)))).. (def 3210: 69 6e 65 20 28 25 63 61 72 73 2b 63 64 72 73 20 ine (%cars+cdrs 3220: 6c 69 73 74 73 29 0a 20 20 20 20 28 6c 65 74 20 lists). (let 3230: 66 20 28 5b 6c 73 20 6c 69 73 74 73 5d 20 5b 61 f ([ls lists] [a 3240: 2a 20 27 28 29 5d 20 5b 64 2a 20 27 28 29 5d 29 * '()] [d* '()]) 3250: 0a 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 . (cond. 3260: 20 20 20 20 5b 28 70 61 69 72 3f 20 6c 73 29 20 [(pair? ls) 3270: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 5b . (let ([ 3280: 61 20 28 63 61 72 20 6c 73 29 5d 29 0a 20 20 20 a (car ls)]). 3290: 20 20 20 20 20 20 20 28 69 66 20 28 70 61 69 72 (if (pair 32a0: 3f 20 61 29 20 0a 20 20 20 20 20 20 20 20 20 20 ? a) . 32b0: 20 20 20 20 28 66 20 28 63 64 72 20 6c 73 29 20 (f (cdr ls) 32c0: 28 63 6f 6e 73 20 28 63 61 72 20 61 29 20 61 2a (cons (car a) a* 32d0: 29 20 28 63 6f 6e 73 20 28 63 64 72 20 61 29 20 ) (cons (cdr a) 32e0: 64 2a 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 d*)). 32f0: 20 20 20 28 76 61 6c 75 65 73 20 27 28 29 20 27 (values '() ' 3300: 28 29 29 29 29 5d 0a 20 20 20 20 20 20 20 5b 65 ())))]. [e 3310: 6c 73 65 20 28 76 61 6c 75 65 73 20 28 72 65 76 lse (values (rev 3320: 65 72 73 65 20 61 2a 29 20 28 72 65 76 65 72 73 erse a*) (revers 3330: 65 20 64 2a 29 29 5d 29 29 29 0a 0a 20 20 28 64 e d*))]))).. (d 3340: 65 66 69 6e 65 20 28 25 63 61 72 73 2b 63 64 72 efine (%cars+cdr 3350: 73 2b 20 6c 69 73 74 73 20 63 61 72 73 2d 66 69 s+ lists cars-fi 3360: 6e 61 6c 29 0a 20 20 20 20 28 63 61 6c 6c 2d 77 nal). (call-w 3370: 69 74 68 2d 63 75 72 72 65 6e 74 2d 63 6f 6e 74 ith-current-cont 3380: 69 6e 75 61 74 69 6f 6e 0a 20 20 20 20 20 28 6c inuation. (l 3390: 61 6d 62 64 61 20 28 61 62 6f 72 74 29 0a 20 20 ambda (abort). 33a0: 20 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 20 (let recur 33b0: 28 28 6c 69 73 74 73 20 6c 69 73 74 73 29 29 0a ((lists lists)). 33c0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 61 (if (pa 33d0: 69 72 3f 20 6c 69 73 74 73 29 0a 20 20 20 20 20 ir? lists). 33e0: 20 20 20 20 20 20 20 20 28 72 65 63 65 69 76 65 (receive 33f0: 20 28 6c 69 73 74 20 6f 74 68 65 72 2d 6c 69 73 (list other-lis 3400: 74 73 29 20 28 63 61 72 2b 63 64 72 20 6c 69 73 ts) (car+cdr lis 3410: 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ts). 3420: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n 3430: 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 74 29 20 ull-list? list) 3440: 28 61 62 6f 72 74 20 27 28 29 20 27 28 29 29 20 (abort '() '()) 3450: 3b 20 4c 49 53 54 20 69 73 20 65 6d 70 74 79 20 ; LIST is empty 3460: 2d 2d 20 62 61 69 6c 20 6f 75 74 0a 20 20 20 20 -- bail out. 3470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3480: 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 28 (receive ( 3490: 61 20 64 29 20 28 63 61 72 2b 63 64 72 20 6c 69 a d) (car+cdr li 34a0: 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 st). 34b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 34c0: 20 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 (receive 34d0: 28 63 61 72 73 20 63 64 72 73 29 20 28 72 65 63 (cars cdrs) (rec 34e0: 75 72 20 6f 74 68 65 72 2d 6c 69 73 74 73 29 0a ur other-lists). 34f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3510: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c (val 3520: 75 65 73 20 28 63 6f 6e 73 20 61 20 63 61 72 73 ues (cons a cars 3530: 29 20 28 63 6f 6e 73 20 64 20 63 64 72 73 29 29 ) (cons d cdrs)) 3540: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 3550: 20 20 28 76 61 6c 75 65 73 20 28 6c 69 73 74 20 (values (list 3560: 63 61 72 73 2d 66 69 6e 61 6c 29 20 27 28 29 29 cars-final) '()) 3570: 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 ))))).. (define 3580: 20 28 25 63 61 72 73 2b 63 64 72 73 2f 6e 6f 2d (%cars+cdrs/no- 3590: 74 65 73 74 20 6c 69 73 74 73 29 0a 20 20 20 20 test lists). 35a0: 28 6c 65 74 20 72 65 63 75 72 20 28 28 6c 69 73 (let recur ((lis 35b0: 74 73 20 6c 69 73 74 73 29 29 0a 20 20 20 20 20 ts lists)). 35c0: 20 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 74 (if (pair? list 35d0: 73 29 0a 20 20 20 20 20 20 20 20 20 20 28 72 65 s). (re 35e0: 63 65 69 76 65 20 28 6c 69 73 74 20 6f 74 68 65 ceive (list othe 35f0: 72 2d 6c 69 73 74 73 29 20 28 63 61 72 2b 63 64 r-lists) (car+cd 3600: 72 20 6c 69 73 74 73 29 0a 20 20 20 20 20 20 20 r lists). 3610: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 63 (rec 3620: 65 69 76 65 20 28 61 20 64 29 20 28 63 61 72 2b eive (a d) (car+ 3630: 63 64 72 20 6c 69 73 74 29 0a 20 20 20 20 20 20 cdr list). 3640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3650: 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 28 (receive ( 3660: 63 61 72 73 20 63 64 72 73 29 20 28 72 65 63 75 cars cdrs) (recu 3670: 72 20 6f 74 68 65 72 2d 6c 69 73 74 73 29 0a 20 r other-lists). 3680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36a0: 20 20 20 20 28 76 61 6c 75 65 73 20 28 63 6f 6e (values (con 36b0: 73 20 61 20 63 61 72 73 29 20 28 63 6f 6e 73 20 s a cars) (cons 36c0: 64 20 63 64 72 73 29 29 29 29 29 0a 20 20 20 20 d cdrs))))). 36d0: 20 20 20 20 20 20 28 76 61 6c 75 65 73 20 27 28 (values '( 36e0: 29 20 27 28 29 29 29 29 29 0a 0a 0a 20 20 3b 3b ) '()))))... ;; 36f0: 20 63 6f 75 6e 74 0a 20 20 3b 3b 20 3b 3b 3b 3b count. ;; ;;;; 3700: 3b 3b 0a 20 20 28 64 65 66 69 6e 65 20 28 63 6f ;;. (define (co 3710: 75 6e 74 20 70 72 65 64 20 6c 69 73 74 31 20 2e unt pred list1 . 3720: 20 6c 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 lists). (che 3730: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure 3740: 3f 20 70 72 65 64 20 63 6f 75 6e 74 29 0a 20 20 ? pred count). 3750: 20 20 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 (if (pair? lis 3760: 74 73 29 0a 0a 20 20 20 20 20 20 20 20 3b 3b 20 ts).. ;; 3770: 4e 2d 61 72 79 20 63 61 73 65 0a 20 20 20 20 20 N-ary case. 3780: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 69 73 (let lp ((lis 3790: 74 31 20 6c 69 73 74 31 29 20 28 6c 69 73 74 73 t1 list1) (lists 37a0: 20 6c 69 73 74 73 29 20 28 69 20 30 29 29 0a 20 lists) (i 0)). 37b0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu 37c0: 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 74 31 29 20 ll-list? list1) 37d0: 69 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 i. 37e0: 28 72 65 63 65 69 76 65 20 28 61 73 20 64 73 29 (receive (as ds) 37f0: 20 28 25 63 61 72 73 2b 63 64 72 73 20 6c 69 73 (%cars+cdrs lis 3800: 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ts). 3810: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 3820: 6e 75 6c 6c 3f 20 61 73 29 20 69 0a 20 20 20 20 null? as) i. 3830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3840: 20 20 20 20 20 20 20 28 6c 70 20 28 63 64 72 20 (lp (cdr 3850: 6c 69 73 74 31 29 20 64 73 0a 20 20 20 20 20 20 list1) ds. 3860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3870: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 70 (if (ap 3880: 70 6c 79 20 70 72 65 64 20 28 63 61 72 20 6c 69 ply pred (car li 3890: 73 74 31 29 20 61 73 29 20 28 2b 20 69 20 31 29 st1) as) (+ i 1) 38a0: 20 69 29 29 29 29 29 29 0a 0a 20 20 20 20 20 20 i)))))).. 38b0: 20 20 3b 3b 20 46 61 73 74 20 70 61 74 68 0a 20 ;; Fast path. 38c0: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 (let lp ( 38d0: 28 6c 69 73 20 6c 69 73 74 31 29 20 28 69 20 30 (lis list1) (i 0 38e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if 38f0: 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 (null-list? lis 3900: 29 20 69 0a 20 20 20 20 20 20 20 20 20 20 20 20 ) i. 3910: 20 20 28 6c 70 20 28 63 64 72 20 6c 69 73 29 20 (lp (cdr lis) 3920: 28 69 66 20 28 70 72 65 64 20 28 63 61 72 20 6c (if (pred (car l 3930: 69 73 29 29 20 28 2b 20 69 20 31 29 20 69 29 29 is)) (+ i 1) i)) 3940: 29 29 29 29 0a 0a 0a 20 20 3b 3b 20 66 6f 6c 64 ))))... ;; fold 3950: 2f 75 6e 66 6f 6c 64 0a 20 20 3b 3b 20 3b 3b 3b /unfold. ;; ;;; 3960: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 20 28 64 65 ;;;;;;;;;.. (de 3970: 66 69 6e 65 20 75 6e 66 6f 6c 64 2d 72 69 67 68 fine unfold-righ 3980: 74 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 t. (case-lamb 3990: 64 61 0a 20 20 20 20 20 5b 28 70 20 66 20 67 20 da. [(p f g 39a0: 73 65 65 64 29 0a 20 20 20 20 20 20 28 75 6e 66 seed). (unf 39b0: 6f 6c 64 2d 72 69 67 68 74 20 70 20 66 20 67 20 old-right p f g 39c0: 73 65 65 64 20 27 28 29 29 5d 0a 20 20 20 20 20 seed '())]. 39d0: 5b 28 70 20 66 20 67 20 73 65 65 64 20 74 61 69 [(p f g seed tai 39e0: 6c 29 0a 20 20 20 20 20 20 28 63 68 65 63 6b 2d l). (check- 39f0: 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 arg procedure? p 3a00: 20 75 6e 66 6f 6c 64 2d 72 69 67 68 74 29 0a 20 unfold-right). 3a10: 20 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 (check-arg 3a20: 70 72 6f 63 65 64 75 72 65 3f 20 66 20 75 6e 66 procedure? f unf 3a30: 6f 6c 64 2d 72 69 67 68 74 29 0a 20 20 20 20 20 old-right). 3a40: 20 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 (check-arg proc 3a50: 65 64 75 72 65 3f 20 67 20 75 6e 66 6f 6c 64 2d edure? g unfold- 3a60: 72 69 67 68 74 29 0a 20 20 20 20 20 20 28 6c 65 right). (le 3a70: 74 20 6c 70 20 28 28 73 65 65 64 20 73 65 65 64 t lp ((seed seed 3a80: 29 20 28 61 6e 73 20 74 61 69 6c 29 29 0a 20 20 ) (ans tail)). 3a90: 20 20 20 20 20 20 28 69 66 20 28 70 20 73 65 65 (if (p see 3aa0: 64 29 20 61 6e 73 0a 20 20 20 20 20 20 20 20 20 d) ans. 3ab0: 20 20 20 28 6c 70 20 28 67 20 73 65 65 64 29 0a (lp (g seed). 3ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3ad0: 28 63 6f 6e 73 20 28 66 20 73 65 65 64 29 20 61 (cons (f seed) a 3ae0: 6e 73 29 29 29 29 5d 29 29 0a 0a 0a 20 20 28 64 ns))))]))... (d 3af0: 65 66 69 6e 65 20 28 75 6e 66 6f 6c 64 20 70 20 efine (unfold p 3b00: 66 20 67 20 73 65 65 64 20 2e 20 6d 61 79 62 65 f g seed . maybe 3b10: 2d 74 61 69 6c 2d 67 65 6e 29 0a 20 20 20 20 28 -tail-gen). ( 3b20: 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 check-arg proced 3b30: 75 72 65 3f 20 70 20 75 6e 66 6f 6c 64 29 0a 20 ure? p unfold). 3b40: 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 70 72 (check-arg pr 3b50: 6f 63 65 64 75 72 65 3f 20 66 20 75 6e 66 6f 6c ocedure? f unfol 3b60: 64 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 d). (check-ar 3b70: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 67 20 75 g procedure? g u 3b80: 6e 66 6f 6c 64 29 0a 20 20 20 20 28 69 66 20 28 nfold). (if ( 3b90: 70 61 69 72 3f 20 6d 61 79 62 65 2d 74 61 69 6c pair? maybe-tail 3ba0: 2d 67 65 6e 29 20 3b 3b 3b 20 73 6f 20 6d 75 63 -gen) ;;; so muc 3bb0: 68 20 66 6f 72 20 3a 6f 70 74 69 6f 6e 61 6c 20 h for :optional 3bc0: 28 61 67 68 75 6c 6f 75 6d 29 0a 0a 20 20 20 20 (aghuloum).. 3bd0: 20 20 20 20 28 6c 65 74 20 28 28 74 61 69 6c 2d (let ((tail- 3be0: 67 65 6e 20 28 63 61 72 20 6d 61 79 62 65 2d 74 gen (car maybe-t 3bf0: 61 69 6c 2d 67 65 6e 29 29 29 0a 20 20 20 20 20 ail-gen))). 3c00: 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 (if (pair? 3c10: 28 63 64 72 20 6d 61 79 62 65 2d 74 61 69 6c 2d (cdr maybe-tail- 3c20: 67 65 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 gen)). 3c30: 20 20 20 20 28 61 70 70 6c 79 20 65 72 72 6f 72 (apply error 3c40: 20 27 75 6e 66 6f 6c 64 20 22 54 6f 6f 20 6d 61 'unfold "Too ma 3c50: 6e 79 20 61 72 67 75 6d 65 6e 74 73 22 20 70 20 ny arguments" p 3c60: 66 20 67 20 73 65 65 64 20 6d 61 79 62 65 2d 74 f g seed maybe-t 3c70: 61 69 6c 2d 67 65 6e 29 0a 0a 20 20 20 20 20 20 ail-gen).. 3c80: 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 63 (let rec 3c90: 75 72 20 28 28 73 65 65 64 20 73 65 65 64 29 29 ur ((seed seed)) 3ca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3cb0: 20 28 69 66 20 28 70 20 73 65 65 64 29 20 28 74 (if (p seed) (t 3cc0: 61 69 6c 2d 67 65 6e 20 73 65 65 64 29 0a 20 20 ail-gen seed). 3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3ce0: 20 20 28 63 6f 6e 73 20 28 66 20 73 65 65 64 29 (cons (f seed) 3cf0: 20 28 72 65 63 75 72 20 28 67 20 73 65 65 64 29 (recur (g seed) 3d00: 29 29 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 )))))).. 3d10: 28 6c 65 74 20 72 65 63 75 72 20 28 28 73 65 65 (let recur ((see 3d20: 64 20 73 65 65 64 29 29 0a 20 20 20 20 20 20 20 d seed)). 3d30: 20 20 20 28 69 66 20 28 70 20 73 65 65 64 29 20 (if (p seed) 3d40: 27 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 '(). 3d50: 20 20 28 63 6f 6e 73 20 28 66 20 73 65 65 64 29 (cons (f seed) 3d60: 20 28 72 65 63 75 72 20 28 67 20 73 65 65 64 29 (recur (g seed) 3d70: 29 29 29 29 29 29 0a 20 20 0a 0a 20 20 28 64 65 )))))). .. (de 3d80: 66 69 6e 65 20 28 66 6f 6c 64 20 6b 6f 6e 73 20 fine (fold kons 3d90: 6b 6e 69 6c 20 6c 69 73 31 20 2e 20 6c 69 73 74 knil lis1 . list 3da0: 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 s). (check-ar 3db0: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 6b 6f 6e g procedure? kon 3dc0: 73 20 66 6f 6c 64 29 0a 20 20 20 20 28 69 66 20 s fold). (if 3dd0: 28 70 61 69 72 3f 20 6c 69 73 74 73 29 0a 20 20 (pair? lists). 3de0: 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 (let lp (( 3df0: 6c 69 73 74 73 20 28 63 6f 6e 73 20 6c 69 73 31 lists (cons lis1 3e00: 20 6c 69 73 74 73 29 29 20 28 61 6e 73 20 6b 6e lists)) (ans kn 3e10: 69 6c 29 29 09 3b 20 4e 2d 61 72 79 20 63 61 73 il)).; N-ary cas 3e20: 65 0a 20 20 20 20 20 20 20 20 20 20 28 72 65 63 e. (rec 3e30: 65 69 76 65 20 28 63 61 72 73 2b 61 6e 73 20 63 eive (cars+ans c 3e40: 64 72 73 29 20 28 25 63 61 72 73 2b 63 64 72 73 drs) (%cars+cdrs 3e50: 2b 20 6c 69 73 74 73 20 61 6e 73 29 0a 20 20 20 + lists ans). 3e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3e70: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 61 72 73 2b (if (null? cars+ 3e80: 61 6e 73 29 20 61 6e 73 20 3b 20 44 6f 6e 65 2e ans) ans ; Done. 3e90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3ea0: 20 20 20 20 20 20 20 20 28 6c 70 20 63 64 72 73 (lp cdrs 3eb0: 20 28 61 70 70 6c 79 20 6b 6f 6e 73 20 63 61 72 (apply kons car 3ec0: 73 2b 61 6e 73 29 29 29 29 29 0a 20 20 20 20 20 s+ans))))). 3ed0: 20 20 20 0a 20 20 20 20 20 20 20 20 28 6c 65 74 . (let 3ee0: 20 6c 70 20 28 28 6c 69 73 20 6c 69 73 31 29 20 lp ((lis lis1) 3ef0: 28 61 6e 73 20 6b 6e 69 6c 29 29 09 09 09 3b 20 (ans knil))...; 3f00: 46 61 73 74 20 70 61 74 68 0a 20 20 20 20 20 20 Fast path. 3f10: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 (if (null-li 3f20: 73 74 3f 20 6c 69 73 29 20 61 6e 73 0a 20 20 20 st? lis) ans. 3f30: 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 (lp ( 3f40: 63 64 72 20 6c 69 73 29 20 28 6b 6f 6e 73 20 28 cdr lis) (kons ( 3f50: 63 61 72 20 6c 69 73 29 20 61 6e 73 29 29 29 29 car lis) ans)))) 3f60: 29 29 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ))... (define ( 3f70: 66 6f 6c 64 2d 72 69 67 68 74 20 6b 6f 6e 73 20 fold-right kons 3f80: 6b 6e 69 6c 20 6c 69 73 31 20 2e 20 6c 69 73 74 knil lis1 . list 3f90: 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 s). (check-ar 3fa0: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 6b 6f 6e g procedure? kon 3fb0: 73 20 66 6f 6c 64 2d 72 69 67 68 74 29 0a 20 20 s fold-right). 3fc0: 20 20 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 (if (pair? lis 3fd0: 74 73 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 ts). (let 3fe0: 20 72 65 63 75 72 20 28 28 6c 69 73 74 73 20 28 recur ((lists ( 3ff0: 63 6f 6e 73 20 6c 69 73 31 20 6c 69 73 74 73 29 cons lis1 lists) 4000: 29 29 09 09 3b 20 4e 2d 61 72 79 20 63 61 73 65 ))..; N-ary case 4010: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let 4020: 28 28 63 64 72 73 20 28 25 63 64 72 73 20 6c 69 ((cdrs (%cdrs li 4030: 73 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 sts))). 4040: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 64 (if (null? cd 4050: 72 73 29 20 6b 6e 69 6c 0a 20 20 20 20 20 20 20 rs) knil. 4060: 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 (apply 4070: 6b 6f 6e 73 20 28 25 63 61 72 73 2b 20 6c 69 73 kons (%cars+ lis 4080: 74 73 20 28 72 65 63 75 72 20 63 64 72 73 29 29 ts (recur cdrs)) 4090: 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 28 6c )))).. (l 40a0: 65 74 20 72 65 63 75 72 20 28 28 6c 69 73 20 6c et recur ((lis l 40b0: 69 73 31 29 29 09 09 09 09 3b 20 46 61 73 74 20 is1))....; Fast 40c0: 70 61 74 68 0a 20 20 20 20 20 20 20 20 20 20 28 path. ( 40d0: 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c if (null-list? l 40e0: 69 73 29 20 6b 6e 69 6c 0a 20 20 20 20 20 20 20 is) knil. 40f0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 65 (let ((he 4100: 61 64 20 28 63 61 72 20 6c 69 73 29 29 29 0a 20 ad (car lis))). 4110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 4120: 6b 6f 6e 73 20 68 65 61 64 20 28 72 65 63 75 72 kons head (recur 4130: 20 28 63 64 72 20 6c 69 73 29 29 29 29 29 29 29 (cdr lis))))))) 4140: 29 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 70 )... (define (p 4150: 61 69 72 2d 66 6f 6c 64 2d 72 69 67 68 74 20 66 air-fold-right f 4160: 20 7a 65 72 6f 20 6c 69 73 31 20 2e 20 6c 69 73 zero lis1 . lis 4170: 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 ts). (check-a 4180: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 66 20 rg procedure? f 4190: 70 61 69 72 2d 66 6f 6c 64 2d 72 69 67 68 74 29 pair-fold-right) 41a0: 0a 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 . (if (pair? 41b0: 6c 69 73 74 73 29 0a 20 20 20 20 20 20 20 20 28 lists). ( 41c0: 6c 65 74 20 72 65 63 75 72 20 28 28 6c 69 73 74 let recur ((list 41d0: 73 20 28 63 6f 6e 73 20 6c 69 73 31 20 6c 69 73 s (cons lis1 lis 41e0: 74 73 29 29 29 09 09 3b 20 4e 2d 61 72 79 20 63 ts)))..; N-ary c 41f0: 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 28 6c ase. (l 4200: 65 74 20 28 28 63 64 72 73 20 28 25 63 64 72 73 et ((cdrs (%cdrs 4210: 20 6c 69 73 74 73 29 29 29 0a 20 20 20 20 20 20 lists))). 4220: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null? 4230: 20 63 64 72 73 29 20 7a 65 72 6f 0a 20 20 20 20 cdrs) zero. 4240: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app 4250: 6c 79 20 66 20 28 61 70 70 65 6e 64 21 20 6c 69 ly f (append! li 4260: 73 74 73 20 28 6c 69 73 74 20 28 72 65 63 75 72 sts (list (recur 4270: 20 63 64 72 73 29 29 29 29 29 29 29 0a 0a 20 20 cdrs))))))).. 4280: 20 20 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 (let recur 4290: 20 28 28 6c 69 73 20 6c 69 73 31 29 29 09 09 09 ((lis lis1))... 42a0: 09 3b 20 46 61 73 74 20 70 61 74 68 0a 20 20 20 .; Fast path. 42b0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null 42c0: 2d 6c 69 73 74 3f 20 6c 69 73 29 20 7a 65 72 6f -list? lis) zero 42d0: 20 28 66 20 6c 69 73 20 28 72 65 63 75 72 20 28 (f lis (recur ( 42e0: 63 64 72 20 6c 69 73 29 29 29 29 29 29 29 0a 0a cdr lis))))))).. 42f0: 20 20 28 64 65 66 69 6e 65 20 28 70 61 69 72 2d (define (pair- 4300: 66 6f 6c 64 20 66 20 7a 65 72 6f 20 6c 69 73 31 fold f zero lis1 4310: 20 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 63 . lists). (c 4320: 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 heck-arg procedu 4330: 72 65 3f 20 66 20 70 61 69 72 2d 66 6f 6c 64 29 re? f pair-fold) 4340: 0a 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 . (if (pair? 4350: 6c 69 73 74 73 29 0a 20 20 20 20 20 20 20 20 28 lists). ( 4360: 6c 65 74 20 6c 70 20 28 28 6c 69 73 74 73 20 28 let lp ((lists ( 4370: 63 6f 6e 73 20 6c 69 73 31 20 6c 69 73 74 73 29 cons lis1 lists) 4380: 29 20 28 61 6e 73 20 7a 65 72 6f 29 29 09 3b 20 ) (ans zero)).; 4390: 4e 2d 61 72 79 20 63 61 73 65 0a 20 20 20 20 20 N-ary case. 43a0: 20 20 20 20 20 28 6c 65 74 20 28 28 74 61 69 6c (let ((tail 43b0: 73 20 28 25 63 64 72 73 20 6c 69 73 74 73 29 29 s (%cdrs lists)) 43c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i 43d0: 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 73 29 20 f (null? tails) 43e0: 61 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ans. 43f0: 20 20 20 20 28 6c 70 20 74 61 69 6c 73 20 28 61 (lp tails (a 4400: 70 70 6c 79 20 66 20 28 61 70 70 65 6e 64 21 20 pply f (append! 4410: 6c 69 73 74 73 20 28 6c 69 73 74 20 61 6e 73 29 lists (list ans) 4420: 29 29 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 )))))).. 4430: 28 6c 65 74 20 6c 70 20 28 28 6c 69 73 20 6c 69 (let lp ((lis li 4440: 73 31 29 20 28 61 6e 73 20 7a 65 72 6f 29 29 0a s1) (ans zero)). 4450: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n 4460: 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 20 61 ull-list? lis) a 4470: 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ns. 4480: 20 28 6c 65 74 20 28 28 74 61 69 6c 20 28 63 64 (let ((tail (cd 4490: 72 20 6c 69 73 29 29 29 09 09 3b 20 47 72 61 62 r lis)))..; Grab 44a0: 20 74 68 65 20 63 64 72 20 6e 6f 77 2c 0a 20 20 the cdr now,. 44b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 44c0: 70 20 74 61 69 6c 20 28 66 20 6c 69 73 20 61 6e p tail (f lis an 44d0: 73 29 29 29 29 29 29 29 09 3b 20 69 6e 20 63 61 s))))))).; in ca 44e0: 73 65 20 46 20 53 45 54 2d 43 44 52 21 73 20 4c se F SET-CDR!s L 44f0: 49 53 2e 0a 0a 20 20 3b 3b 20 52 45 44 55 43 45 IS... ;; REDUCE 4500: 20 61 6e 64 20 52 45 44 55 43 45 2d 52 49 47 48 and REDUCE-RIGH 4510: 54 20 6f 6e 6c 79 20 75 73 65 20 52 49 44 45 4e T only use RIDEN 4520: 54 49 54 59 20 69 6e 20 74 68 65 20 65 6d 70 74 TITY in the empt 4530: 79 2d 6c 69 73 74 20 63 61 73 65 2e 0a 20 20 3b y-list case.. ; 4540: 3b 20 54 68 65 73 65 20 63 61 6e 6e 6f 74 20 6d ; These cannot m 4550: 65 61 6e 69 6e 67 66 75 6c 6c 79 20 62 65 20 6e eaningfully be n 4560: 2d 61 72 79 2e 0a 0a 20 20 28 64 65 66 69 6e 65 -ary... (define 4570: 20 28 72 65 64 75 63 65 20 66 20 72 69 64 65 6e (reduce f riden 4580: 74 69 74 79 20 6c 69 73 29 0a 20 20 20 20 28 63 tity lis). (c 4590: 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 heck-arg procedu 45a0: 72 65 3f 20 66 20 72 65 64 75 63 65 29 0a 20 20 re? f reduce). 45b0: 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 (if (null-list 45c0: 3f 20 6c 69 73 29 20 72 69 64 65 6e 74 69 74 79 ? lis) ridentity 45d0: 0a 20 20 20 20 20 20 20 20 28 66 6f 6c 64 20 66 . (fold f 45e0: 20 28 63 61 72 20 6c 69 73 29 20 28 63 64 72 20 (car lis) (cdr 45f0: 6c 69 73 29 29 29 29 0a 0a 20 20 28 64 65 66 69 lis)))).. (defi 4600: 6e 65 20 28 72 65 64 75 63 65 2d 72 69 67 68 74 ne (reduce-right 4610: 20 66 20 72 69 64 65 6e 74 69 74 79 20 6c 69 73 f ridentity lis 4620: 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 ). (check-arg 4630: 20 70 72 6f 63 65 64 75 72 65 3f 20 66 20 72 65 procedure? f re 4640: 64 75 63 65 2d 72 69 67 68 74 29 0a 20 20 20 20 duce-right). 4650: 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 (if (null-list? 4660: 6c 69 73 29 20 72 69 64 65 6e 74 69 74 79 0a 20 lis) ridentity. 4670: 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 63 75 (let recu 4680: 72 20 28 28 68 65 61 64 20 28 63 61 72 20 6c 69 r ((head (car li 4690: 73 29 29 20 28 6c 69 73 20 28 63 64 72 20 6c 69 s)) (lis (cdr li 46a0: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 s))). ( 46b0: 69 66 20 28 70 61 69 72 3f 20 6c 69 73 29 0a 20 if (pair? lis). 46c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 20 (f 46d0: 68 65 61 64 20 28 72 65 63 75 72 20 28 63 61 72 head (recur (car 46e0: 20 6c 69 73 29 20 28 63 64 72 20 6c 69 73 29 29 lis) (cdr lis)) 46f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4700: 68 65 61 64 29 29 29 29 0a 0a 20 20 3b 3b 20 4d head)))).. ;; M 4710: 61 70 70 65 72 73 3a 20 61 70 70 65 6e 64 2d 6d appers: append-m 4720: 61 70 20 61 70 70 65 6e 64 2d 6d 61 70 21 20 70 ap append-map! p 4730: 61 69 72 2d 66 6f 72 2d 65 61 63 68 20 6d 61 70 air-for-each map 4740: 21 20 66 69 6c 74 65 72 2d 6d 61 70 20 6d 61 70 ! filter-map map 4750: 2d 69 6e 2d 6f 72 64 65 72 0a 20 20 3b 3b 20 3b -in-order. ;; ; 4760: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 4770: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 4780: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 4790: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 47a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 20 28 64 ;;;;;;;;;;.. (d 47b0: 65 66 69 6e 65 20 28 61 70 70 65 6e 64 2d 6d 61 efine (append-ma 47c0: 70 20 66 20 6c 69 73 31 20 2e 20 6c 69 73 74 73 p f lis1 . lists 47d0: 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 ). (check-arg 47e0: 20 70 72 6f 63 65 64 75 72 65 3f 20 66 20 61 70 procedure? f ap 47f0: 70 65 6e 64 2d 6d 61 70 29 0a 20 20 20 20 28 72 pend-map). (r 4800: 65 61 6c 6c 79 2d 61 70 70 65 6e 64 2d 6d 61 70 eally-append-map 4810: 20 61 70 70 65 6e 64 20 20 66 20 6c 69 73 31 20 append f lis1 4820: 6c 69 73 74 73 29 29 0a 20 20 28 64 65 66 69 6e lists)). (defin 4830: 65 20 28 61 70 70 65 6e 64 2d 6d 61 70 21 20 66 e (append-map! f 4840: 20 6c 69 73 31 20 2e 20 6c 69 73 74 73 29 20 0a lis1 . lists) . 4850: 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 70 (check-arg p 4860: 72 6f 63 65 64 75 72 65 3f 20 66 20 61 70 70 65 rocedure? f appe 4870: 6e 64 2d 6d 61 70 21 29 0a 20 20 20 20 28 72 65 nd-map!). (re 4880: 61 6c 6c 79 2d 61 70 70 65 6e 64 2d 6d 61 70 20 ally-append-map 4890: 61 70 70 65 6e 64 21 20 66 20 6c 69 73 31 20 6c append! f lis1 l 48a0: 69 73 74 73 29 29 0a 0a 20 20 28 64 65 66 69 6e ists)).. (defin 48b0: 65 20 28 72 65 61 6c 6c 79 2d 61 70 70 65 6e 64 e (really-append 48c0: 2d 6d 61 70 20 61 70 70 65 6e 64 65 72 20 66 20 -map appender f 48d0: 6c 69 73 31 20 6c 69 73 74 73 29 0a 20 20 20 20 lis1 lists). 48e0: 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 74 73 (if (pair? lists 48f0: 29 0a 20 20 20 20 20 20 20 20 28 72 65 63 65 69 ). (recei 4900: 76 65 20 28 63 61 72 73 20 63 64 72 73 29 20 28 ve (cars cdrs) ( 4910: 25 63 61 72 73 2b 63 64 72 73 20 28 63 6f 6e 73 %cars+cdrs (cons 4920: 20 6c 69 73 31 20 6c 69 73 74 73 29 29 0a 20 20 lis1 lists)). 4930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 4940: 69 66 20 28 6e 75 6c 6c 3f 20 63 61 72 73 29 20 if (null? cars) 4950: 27 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 '(). 4960: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 (let re 4970: 63 75 72 20 28 28 63 61 72 73 20 63 61 72 73 29 cur ((cars cars) 4980: 20 28 63 64 72 73 20 63 64 72 73 29 29 0a 20 20 (cdrs cdrs)). 4990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 49a0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 73 (let ((vals 49b0: 20 28 61 70 70 6c 79 20 66 20 63 61 72 73 29 29 (apply f cars)) 49c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 49d0: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 63 65 (rece 49e0: 69 76 65 20 28 63 61 72 73 32 20 63 64 72 73 32 ive (cars2 cdrs2 49f0: 29 20 28 25 63 61 72 73 2b 63 64 72 73 20 63 64 ) (%cars+cdrs cd 4a00: 72 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 rs). 4a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4a20: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null? 4a30: 20 63 61 72 73 32 29 20 76 61 6c 73 0a 20 20 20 cars2) vals. 4a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4a60: 20 20 20 28 61 70 70 65 6e 64 65 72 20 76 61 6c (appender val 4a70: 73 20 28 72 65 63 75 72 20 63 61 72 73 32 20 63 s (recur cars2 c 4a80: 64 72 73 32 29 29 29 29 29 29 29 29 0a 0a 20 20 drs2)))))))).. 4a90: 20 20 20 20 20 20 3b 3b 20 46 61 73 74 20 70 61 ;; Fast pa 4aa0: 74 68 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 th. (if ( 4ab0: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 31 29 null-list? lis1) 4ac0: 20 27 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 '(). 4ad0: 20 28 6c 65 74 20 72 65 63 75 72 20 28 28 65 6c (let recur ((el 4ae0: 74 20 28 63 61 72 20 6c 69 73 31 29 29 20 28 72 t (car lis1)) (r 4af0: 65 73 74 20 28 63 64 72 20 6c 69 73 31 29 29 29 est (cdr lis1))) 4b00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . ( 4b10: 6c 65 74 20 28 28 76 61 6c 73 20 28 66 20 65 6c let ((vals (f el 4b20: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))). 4b30: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c (if (null-l 4b40: 69 73 74 3f 20 72 65 73 74 29 20 76 61 6c 73 0a ist? rest) vals. 4b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4b60: 20 20 20 20 28 61 70 70 65 6e 64 65 72 20 76 61 (appender va 4b70: 6c 73 20 28 72 65 63 75 72 20 28 63 61 72 20 72 ls (recur (car r 4b80: 65 73 74 29 20 28 63 64 72 20 72 65 73 74 29 29 est) (cdr rest)) 4b90: 29 29 29 29 29 29 29 0a 0a 0a 20 20 28 64 65 66 )))))))... (def 4ba0: 69 6e 65 20 28 70 61 69 72 2d 66 6f 72 2d 65 61 ine (pair-for-ea 4bb0: 63 68 20 70 72 6f 63 20 6c 69 73 31 20 2e 20 6c ch proc lis1 . l 4bc0: 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b ists). (check 4bd0: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 4be0: 70 72 6f 63 20 70 61 69 72 2d 66 6f 72 2d 65 61 proc pair-for-ea 4bf0: 63 68 29 0a 20 20 20 20 28 69 66 20 28 70 61 69 ch). (if (pai 4c00: 72 3f 20 6c 69 73 74 73 29 0a 0a 20 20 20 20 20 r? lists).. 4c10: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 69 73 (let lp ((lis 4c20: 74 73 20 28 63 6f 6e 73 20 6c 69 73 31 20 6c 69 ts (cons lis1 li 4c30: 73 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 sts))). 4c40: 20 28 6c 65 74 20 28 28 74 61 69 6c 73 20 28 25 (let ((tails (% 4c50: 63 64 72 73 20 6c 69 73 74 73 29 29 29 0a 20 20 cdrs lists))). 4c60: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 (if (p 4c70: 61 69 72 3f 20 74 61 69 6c 73 29 0a 20 20 20 20 air? tails). 4c80: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg 4c90: 69 6e 20 28 61 70 70 6c 79 20 70 72 6f 63 20 6c in (apply proc l 4ca0: 69 73 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 ists). 4cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 (lp 4cc0: 20 74 61 69 6c 73 29 29 29 29 29 0a 0a 20 20 20 tails))))).. 4cd0: 20 20 20 20 20 3b 3b 20 46 61 73 74 20 70 61 74 ;; Fast pat 4ce0: 68 2e 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 h.. (let 4cf0: 6c 70 20 28 28 6c 69 73 20 6c 69 73 31 29 29 0a lp ((lis lis1)). 4d00: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n 4d10: 6f 74 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c ot (null-list? l 4d20: 69 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 is)). 4d30: 20 20 20 28 6c 65 74 20 28 28 74 61 69 6c 20 28 (let ((tail ( 4d40: 63 64 72 20 6c 69 73 29 29 29 09 3b 20 47 72 61 cdr lis))).; Gra 4d50: 62 20 74 68 65 20 63 64 72 20 6e 6f 77 2c 0a 20 b the cdr now,. 4d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 4d70: 70 72 6f 63 20 6c 69 73 29 09 09 3b 20 69 6e 20 proc lis)..; in 4d80: 63 61 73 65 20 50 52 4f 43 20 53 45 54 2d 43 44 case PROC SET-CD 4d90: 52 21 73 20 4c 49 53 2e 0a 20 20 20 20 20 20 20 R!s LIS.. 4da0: 20 20 20 20 20 20 20 20 20 28 6c 70 20 74 61 69 (lp tai 4db0: 6c 29 29 29 29 29 29 0a 0a 20 20 3b 3b 20 57 65 l)))))).. ;; We 4dc0: 20 73 74 6f 70 20 77 68 65 6e 20 4c 49 53 31 20 stop when LIS1 4dd0: 72 75 6e 73 20 6f 75 74 2c 20 6e 6f 74 20 77 68 runs out, not wh 4de0: 65 6e 20 61 6e 79 20 6c 69 73 74 20 72 75 6e 73 en any list runs 4df0: 20 6f 75 74 2e 0a 20 20 28 64 65 66 69 6e 65 20 out.. (define 4e00: 28 6d 61 70 21 20 66 20 6c 69 73 31 20 2e 20 6c (map! f lis1 . l 4e10: 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b ists). (check 4e20: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 4e30: 66 20 6d 61 70 21 29 0a 20 20 20 20 28 69 66 20 f map!). (if 4e40: 28 70 61 69 72 3f 20 6c 69 73 74 73 29 0a 20 20 (pair? lists). 4e50: 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 (let lp (( 4e60: 6c 69 73 31 20 6c 69 73 31 29 20 28 6c 69 73 74 lis1 lis1) (list 4e70: 73 20 6c 69 73 74 73 29 29 0a 20 20 20 20 20 20 s lists)). 4e80: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu 4e90: 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 31 29 29 0a ll-list? lis1)). 4ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r 4eb0: 65 63 65 69 76 65 20 28 68 65 61 64 73 20 74 61 eceive (heads ta 4ec0: 69 6c 73 29 20 28 25 63 61 72 73 2b 63 64 72 73 ils) (%cars+cdrs 4ed0: 2f 6e 6f 2d 74 65 73 74 20 6c 69 73 74 73 29 0a /no-test lists). 4ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4ef0: 20 20 20 20 20 20 20 28 73 65 74 2d 63 61 72 21 (set-car! 4f00: 20 6c 69 73 31 20 28 61 70 70 6c 79 20 66 20 28 lis1 (apply f ( 4f10: 63 61 72 20 6c 69 73 31 29 20 68 65 61 64 73 29 car lis1) heads) 4f20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4f30: 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 63 64 (lp (cd 4f40: 72 20 6c 69 73 31 29 20 74 61 69 6c 73 29 29 29 r lis1) tails))) 4f50: 29 0a 0a 20 20 20 20 20 20 20 20 3b 3b 20 46 61 ).. ;; Fa 4f60: 73 74 20 70 61 74 68 2e 0a 20 20 20 20 20 20 20 st path.. 4f70: 20 28 70 61 69 72 2d 66 6f 72 2d 65 61 63 68 20 (pair-for-each 4f80: 28 6c 61 6d 62 64 61 20 28 70 61 69 72 29 20 28 (lambda (pair) ( 4f90: 73 65 74 2d 63 61 72 21 20 70 61 69 72 20 28 66 set-car! pair (f 4fa0: 20 28 63 61 72 20 70 61 69 72 29 29 29 29 20 6c (car pair)))) l 4fb0: 69 73 31 29 29 0a 20 20 20 20 6c 69 73 31 29 0a is1)). lis1). 4fc0: 0a 0a 20 20 3b 3b 20 4d 61 70 20 46 20 61 63 72 .. ;; Map F acr 4fd0: 6f 73 73 20 4c 2c 20 61 6e 64 20 73 61 76 65 20 oss L, and save 4fe0: 75 70 20 61 6c 6c 20 74 68 65 20 6e 6f 6e 2d 66 up all the non-f 4ff0: 61 6c 73 65 20 72 65 73 75 6c 74 73 2e 0a 20 20 alse results.. 5000: 28 64 65 66 69 6e 65 20 28 66 69 6c 74 65 72 2d (define (filter- 5010: 6d 61 70 20 66 20 6c 69 73 31 20 2e 20 6c 69 73 map f lis1 . lis 5020: 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 ts). (check-a 5030: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 66 20 rg procedure? f 5040: 66 69 6c 74 65 72 2d 6d 61 70 29 0a 20 20 20 20 filter-map). 5050: 28 69 66 20 28 70 61 69 72 3f 20 6c 69 73 74 73 (if (pair? lists 5060: 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 ). (let r 5070: 65 63 75 72 20 28 28 6c 69 73 74 73 20 28 63 6f ecur ((lists (co 5080: 6e 73 20 6c 69 73 31 20 6c 69 73 74 73 29 29 29 ns lis1 lists))) 5090: 0a 20 20 20 20 20 20 20 20 20 20 28 72 65 63 65 . (rece 50a0: 69 76 65 20 28 63 61 72 73 20 63 64 72 73 29 20 ive (cars cdrs) 50b0: 28 25 63 61 72 73 2b 63 64 72 73 20 6c 69 73 74 (%cars+cdrs list 50c0: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s). 50d0: 20 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f (if (pair? 50e0: 20 63 61 72 73 29 0a 20 20 20 20 20 20 20 20 20 cars). 50f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c 5100: 6f 6e 64 20 28 28 61 70 70 6c 79 20 66 20 63 61 ond ((apply f ca 5110: 72 73 29 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 rs) => (lambda ( 5120: 78 29 20 28 63 6f 6e 73 20 78 20 28 72 65 63 75 x) (cons x (recu 5130: 72 20 63 64 72 73 29 29 29 29 0a 20 20 20 20 20 r cdrs)))). 5140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5150: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 72 (else (r 5160: 65 63 75 72 20 63 64 72 73 29 29 29 20 3b 20 54 ecur cdrs))) ; T 5170: 61 69 6c 20 63 61 6c 6c 20 69 6e 20 74 68 69 73 ail call in this 5180: 20 61 72 6d 2e 0a 20 20 20 20 20 20 20 20 20 20 arm.. 5190: 20 20 20 20 20 20 20 20 20 20 20 20 20 27 28 29 '() 51a0: 29 29 29 0a 20 20 20 20 20 20 20 20 0a 20 20 20 ))). . 51b0: 20 20 20 20 20 3b 3b 20 46 61 73 74 20 70 61 74 ;; Fast pat 51c0: 68 2e 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 h.. (let 51d0: 72 65 63 75 72 20 28 28 6c 69 73 20 6c 69 73 31 recur ((lis lis1 51e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if 51f0: 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 (null-list? lis 5200: 29 20 6c 69 73 0a 20 20 20 20 20 20 20 20 20 20 ) lis. 5210: 20 20 20 20 28 6c 65 74 20 28 28 74 61 69 6c 20 (let ((tail 5220: 28 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 29 (recur (cdr lis) 5230: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 5240: 20 20 20 20 28 63 6f 6e 64 20 28 28 66 20 28 63 (cond ((f (c 5250: 61 72 20 6c 69 73 29 29 20 3d 3e 20 28 6c 61 6d ar lis)) => (lam 5260: 62 64 61 20 28 78 29 20 28 63 6f 6e 73 20 78 20 bda (x) (cons x 5270: 74 61 69 6c 29 29 29 0a 20 20 20 20 20 20 20 20 tail))). 5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e 5290: 6c 73 65 20 74 61 69 6c 29 29 29 29 29 29 29 0a lse tail))))))). 52a0: 0a 0a 20 20 3b 3b 20 4d 61 70 20 46 20 61 63 72 .. ;; Map F acr 52b0: 6f 73 73 20 6c 69 73 74 73 2c 20 67 75 61 72 61 oss lists, guara 52c0: 6e 74 65 65 69 6e 67 20 74 6f 20 67 6f 20 6c 65 nteeing to go le 52d0: 66 74 2d 74 6f 2d 72 69 67 68 74 2e 0a 20 20 3b ft-to-right.. ; 52e0: 3b 20 4e 4f 54 45 3a 20 53 6f 6d 65 20 69 6d 70 ; NOTE: Some imp 52f0: 6c 65 6d 65 6e 74 61 74 69 6f 6e 73 20 6f 66 20 lementations of 5300: 52 35 52 53 20 4d 41 50 20 61 72 65 20 63 6f 6d R5RS MAP are com 5310: 70 6c 69 61 6e 74 20 77 69 74 68 20 74 68 69 73 pliant with this 5320: 20 73 70 65 63 3b 0a 20 20 3b 3b 20 69 6e 20 77 spec;. ;; in w 5330: 68 69 63 68 20 63 61 73 65 20 74 68 69 73 20 70 hich case this p 5340: 72 6f 63 65 64 75 72 65 20 6d 61 79 20 73 69 6d rocedure may sim 5350: 70 6c 79 20 62 65 20 64 65 66 69 6e 65 64 20 61 ply be defined a 5360: 73 20 61 20 73 79 6e 6f 6e 79 6d 20 66 6f 72 20 s a synonym for 5370: 4d 41 50 2e 0a 0a 20 20 28 64 65 66 69 6e 65 20 MAP... (define 5380: 28 6d 61 70 2d 69 6e 2d 6f 72 64 65 72 20 66 20 (map-in-order f 5390: 6c 69 73 31 20 2e 20 6c 69 73 74 73 29 0a 20 20 lis1 . lists). 53a0: 20 20 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f (check-arg pro 53b0: 63 65 64 75 72 65 3f 20 66 20 6d 61 70 2d 69 6e cedure? f map-in 53c0: 2d 6f 72 64 65 72 29 0a 20 20 20 20 28 69 66 20 -order). (if 53d0: 28 70 61 69 72 3f 20 6c 69 73 74 73 29 0a 20 20 (pair? lists). 53e0: 20 20 20 20 20 20 28 6c 65 74 20 72 65 63 75 72 (let recur 53f0: 20 28 28 6c 69 73 74 73 20 28 63 6f 6e 73 20 6c ((lists (cons l 5400: 69 73 31 20 6c 69 73 74 73 29 29 29 0a 20 20 20 is1 lists))). 5410: 20 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 (receive 5420: 28 63 61 72 73 20 63 64 72 73 29 20 28 25 63 61 (cars cdrs) (%ca 5430: 72 73 2b 63 64 72 73 20 6c 69 73 74 73 29 0a 20 rs+cdrs lists). 5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5450: 20 20 28 69 66 20 28 70 61 69 72 3f 20 63 61 72 (if (pair? car 5460: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s). 5470: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 5480: 28 78 20 28 61 70 70 6c 79 20 66 20 63 61 72 73 (x (apply f cars 5490: 29 29 29 09 09 3b 20 44 6f 20 68 65 61 64 20 66 )))..; Do head f 54a0: 69 72 73 74 2c 0a 20 20 20 20 20 20 20 20 20 20 irst,. 54b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 54c0: 63 6f 6e 73 20 78 20 28 72 65 63 75 72 20 63 64 cons x (recur cd 54d0: 72 73 29 29 29 09 09 3b 20 74 68 65 6e 20 74 61 rs)))..; then ta 54e0: 69 6c 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 il.. 54f0: 20 20 20 20 20 20 20 20 20 20 20 27 28 29 29 29 '())) 5500: 29 0a 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 ). . 5510: 20 20 20 3b 3b 20 46 61 73 74 20 70 61 74 68 2e ;; Fast path. 5520: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 . (let re 5530: 63 75 72 20 28 28 6c 69 73 20 6c 69 73 31 29 29 cur ((lis lis1)) 5540: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 . (if ( 5550: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 20 null-list? lis) 5560: 6c 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 lis. 5570: 20 20 28 6c 65 74 20 28 28 74 61 69 6c 20 28 63 (let ((tail (c 5580: 64 72 20 6c 69 73 29 29 0a 20 20 20 20 20 20 20 dr lis)). 5590: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 78 20 (x 55a0: 28 66 20 28 63 61 72 20 6c 69 73 29 29 29 29 09 (f (car lis)))). 55b0: 09 3b 20 44 6f 20 68 65 61 64 20 66 69 72 73 74 .; Do head first 55c0: 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ,. 55d0: 20 20 28 63 6f 6e 73 20 78 20 28 72 65 63 75 72 (cons x (recur 55e0: 20 74 61 69 6c 29 29 29 29 29 29 29 09 3b 20 74 tail))))))).; t 55f0: 68 65 6e 20 74 61 69 6c 2e 0a 0a 0a 20 20 3b 3b hen tail.... ;; 5600: 20 57 65 20 65 78 74 65 6e 64 20 4d 41 50 20 74 We extend MAP t 5610: 6f 20 68 61 6e 64 6c 65 20 61 72 67 75 6d 65 6e o handle argumen 5620: 74 73 20 6f 66 20 75 6e 65 71 75 61 6c 20 6c 65 ts of unequal le 5630: 6e 67 74 68 2e 0a 20 20 28 64 65 66 69 6e 65 20 ngth.. (define 5640: 6d 61 70 20 6d 61 70 2d 69 6e 2d 6f 72 64 65 72 map map-in-order 5650: 29 09 0a 0a 20 20 3b 3b 20 43 6f 6e 74 72 69 62 )... ;; Contrib 5660: 75 74 65 64 20 62 79 20 4d 69 63 68 61 65 6c 20 uted by Michael 5670: 53 70 65 72 62 65 72 20 73 69 6e 63 65 20 69 74 Sperber since it 5680: 20 77 61 73 20 6d 69 73 73 69 6e 67 20 66 72 6f was missing fro 5690: 6d 20 74 68 65 0a 20 20 3b 3b 20 72 65 66 65 72 m the. ;; refer 56a0: 65 6e 63 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 ence implementat 56b0: 69 6f 6e 2e 0a 20 20 28 64 65 66 69 6e 65 20 28 ion.. (define ( 56c0: 66 6f 72 2d 65 61 63 68 20 66 20 6c 69 73 31 20 for-each f lis1 56d0: 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 69 66 . lists). (if 56e0: 20 28 70 61 69 72 3f 20 6c 69 73 74 73 29 0a 20 (pair? lists). 56f0: 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 63 75 (let recu 5700: 72 20 28 28 6c 69 73 74 73 20 28 63 6f 6e 73 20 r ((lists (cons 5710: 6c 69 73 31 20 6c 69 73 74 73 29 29 29 0a 20 20 lis1 lists))). 5720: 20 20 20 20 20 20 20 20 28 72 65 63 65 69 76 65 (receive 5730: 20 28 63 61 72 73 20 63 64 72 73 29 20 28 25 63 (cars cdrs) (%c 5740: 61 72 73 2b 63 64 72 73 20 6c 69 73 74 73 29 0a ars+cdrs lists). 5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5760: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 63 61 (if (pair? ca 5770: 72 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 rs). 5780: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi 5790: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n. 57a0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl 57b0: 79 20 66 20 63 61 72 73 29 09 3b 20 44 6f 20 68 y f cars).; Do h 57c0: 65 61 64 20 66 69 72 73 74 2c 0a 20 20 20 20 20 ead first,. 57d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 57e0: 20 20 20 20 28 72 65 63 75 72 20 63 64 72 73 29 (recur cdrs) 57f0: 29 29 29 29 09 3b 20 74 68 65 6e 20 74 61 69 6c )))).; then tail 5800: 2e 0a 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 .. . 5810: 20 20 20 3b 3b 20 46 61 73 74 20 70 61 74 68 2e ;; Fast path. 5820: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 . (let re 5830: 63 75 72 20 28 28 6c 69 73 20 6c 69 73 31 29 29 cur ((lis lis1)) 5840: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 . (if ( 5850: 6e 6f 74 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 not (null-list? 5860: 6c 69 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 lis)). 5870: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin. 5880: 20 20 20 20 20 20 20 20 20 20 20 28 66 20 28 63 (f (c 5890: 61 72 20 6c 69 73 29 29 09 09 3b 20 44 6f 20 68 ar lis))..; Do h 58a0: 65 61 64 20 66 69 72 73 74 2c 0a 20 20 20 20 20 ead first,. 58b0: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 63 75 (recu 58c0: 72 20 28 63 64 72 20 6c 69 73 29 29 29 29 29 29 r (cdr lis)))))) 58d0: 29 09 3b 20 74 68 65 6e 20 74 61 69 6c 2e 0a 0a ).; then tail... 58e0: 20 20 3b 3b 20 66 69 6c 74 65 72 2c 20 72 65 6d ;; filter, rem 58f0: 6f 76 65 2c 20 70 61 72 74 69 74 69 6f 6e 0a 20 ove, partition. 5900: 20 3b 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;; ;;;;;;;;;;;; 5910: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 20 ;;;;;;;;;;;;;;. 5920: 20 3b 3b 20 46 49 4c 54 45 52 2c 20 52 45 4d 4f ;; FILTER, REMO 5930: 56 45 2c 20 50 41 52 54 49 54 49 4f 4e 20 61 6e VE, PARTITION an 5940: 64 20 74 68 65 69 72 20 64 65 73 74 72 75 63 74 d their destruct 5950: 69 76 65 20 63 6f 75 6e 74 65 72 70 61 72 74 73 ive counterparts 5960: 20 64 6f 20 6e 6f 74 0a 20 20 3b 3b 20 64 69 73 do not. ;; dis 5970: 6f 72 64 65 72 20 74 68 65 20 65 6c 65 6d 65 6e order the elemen 5980: 74 73 20 6f 66 20 74 68 65 69 72 20 61 72 67 75 ts of their argu 5990: 6d 65 6e 74 2e 0a 0a 20 20 3b 3b 20 54 68 69 73 ment... ;; This 59a0: 20 46 49 4c 54 45 52 20 73 68 61 72 65 73 20 74 FILTER shares t 59b0: 68 65 20 6c 6f 6e 67 65 73 74 20 74 61 69 6c 20 he longest tail 59c0: 6f 66 20 4c 20 74 68 61 74 20 68 61 73 20 6e 6f of L that has no 59d0: 20 64 65 6c 65 74 65 64 20 65 6c 65 6d 65 6e 74 deleted element 59e0: 73 2e 0a 20 20 3b 3b 20 49 66 20 53 63 68 65 6d s.. ;; If Schem 59f0: 65 20 68 61 64 20 6d 75 6c 74 69 2d 63 6f 6e 74 e had multi-cont 5a00: 69 6e 75 61 74 69 6f 6e 20 63 61 6c 6c 73 2c 20 inuation calls, 5a10: 74 68 65 79 20 63 6f 75 6c 64 20 62 65 20 6d 61 they could be ma 5a20: 64 65 20 6d 6f 72 65 20 65 66 66 69 63 69 65 6e de more efficien 5a30: 74 2e 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 66 t... (define (f 5a40: 69 6c 74 65 72 20 70 72 65 64 20 6c 69 73 29 09 ilter pred lis). 5a50: 09 09 3b 20 53 6c 65 61 7a 69 6e 67 20 77 69 74 ..; Sleazing wit 5a60: 68 20 45 51 3f 20 6d 61 6b 65 73 20 74 68 69 73 h EQ? makes this 5a70: 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 . (check-arg 5a80: 70 72 6f 63 65 64 75 72 65 3f 20 70 72 65 64 20 procedure? pred 5a90: 66 69 6c 74 65 72 29 09 09 3b 20 6f 6e 65 20 66 filter)..; one f 5aa0: 61 73 74 65 72 2e 0a 20 20 20 20 28 6c 65 74 20 aster.. (let 5ab0: 72 65 63 75 72 20 28 28 6c 69 73 20 6c 69 73 29 recur ((lis lis) 5ac0: 29 09 09 0a 20 20 20 20 20 20 28 69 66 20 28 6e )... (if (n 5ad0: 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 20 6c ull-list? lis) l 5ae0: 69 73 09 09 09 3b 20 55 73 65 20 4e 4f 54 2d 50 is...; Use NOT-P 5af0: 41 49 52 3f 20 74 6f 20 68 61 6e 64 6c 65 20 64 AIR? to handle d 5b00: 6f 74 74 65 64 20 6c 69 73 74 73 2e 0a 20 20 20 otted lists.. 5b10: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 65 (let ((he 5b20: 61 64 20 28 63 61 72 20 6c 69 73 29 29 0a 20 20 ad (car lis)). 5b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t 5b40: 61 69 6c 20 28 63 64 72 20 6c 69 73 29 29 29 0a ail (cdr lis))). 5b50: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 5b60: 28 70 72 65 64 20 68 65 61 64 29 0a 20 20 20 20 (pred head). 5b70: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let 5b80: 20 28 28 6e 65 77 2d 74 61 69 6c 20 28 72 65 63 ((new-tail (rec 5b90: 75 72 20 74 61 69 6c 29 29 29 09 3b 20 52 65 70 ur tail))).; Rep 5ba0: 6c 69 63 61 74 65 20 74 68 65 20 52 45 43 55 52 licate the RECUR 5bb0: 20 63 61 6c 6c 20 73 6f 0a 20 20 20 20 20 20 20 call so. 5bc0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 5bd0: 65 71 3f 20 74 61 69 6c 20 6e 65 77 2d 74 61 69 eq? tail new-tai 5be0: 6c 29 20 6c 69 73 0a 20 20 20 20 20 20 20 20 20 l) lis. 5bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co 5c00: 6e 73 20 68 65 61 64 20 6e 65 77 2d 74 61 69 6c ns head new-tail 5c10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 5c20: 20 20 20 20 28 72 65 63 75 72 20 74 61 69 6c 29 (recur tail) 5c30: 29 29 29 29 29 09 09 09 3b 20 74 68 69 73 20 6f )))))...; this o 5c40: 6e 65 20 63 61 6e 20 62 65 20 61 20 74 61 69 6c ne can be a tail 5c50: 20 63 61 6c 6c 2e 0a 0a 0a 20 20 28 64 65 66 69 call.... (defi 5c60: 6e 65 20 28 66 69 6c 74 65 72 21 20 70 72 65 64 ne (filter! pred 5c70: 20 6c 69 73 29 0a 20 20 20 20 28 63 68 65 63 6b lis). (check 5c80: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 5c90: 70 72 65 64 20 66 69 6c 74 65 72 21 29 0a 20 20 pred filter!). 5ca0: 20 20 28 6c 65 74 20 6c 70 20 28 28 61 6e 73 20 (let lp ((ans 5cb0: 6c 69 73 29 29 0a 20 20 20 20 20 20 28 63 6f 6e lis)). (con 5cc0: 64 20 28 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 61 d ((null-list? a 5cd0: 6e 73 29 20 20 20 20 20 20 20 61 6e 73 29 09 09 ns) ans).. 5ce0: 09 3b 20 53 63 61 6e 20 6c 6f 6f 6b 69 6e 67 20 .; Scan looking 5cf0: 66 6f 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 for. 5d00: 28 28 6e 6f 74 20 28 70 72 65 64 20 28 63 61 72 ((not (pred (car 5d10: 20 61 6e 73 29 29 29 20 28 6c 70 20 28 63 64 72 ans))) (lp (cdr 5d20: 20 61 6e 73 29 29 29 09 3b 20 66 69 72 73 74 20 ans))).; first 5d30: 63 6f 6e 73 20 6f 66 20 72 65 73 75 6c 74 2e 0a cons of result.. 5d40: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els 5d50: 65 20 28 6c 65 74 72 65 63 20 28 28 73 63 61 6e e (letrec ((scan 5d60: 2d 69 6e 20 28 6c 61 6d 62 64 61 20 28 70 72 65 -in (lambda (pre 5d70: 76 20 6c 69 73 29 0a 20 20 20 20 20 20 20 20 20 v lis). 5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 5da0: 20 28 70 61 69 72 3f 20 6c 69 73 29 0a 20 20 20 (pair? lis). 5db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5dd0: 20 20 20 20 20 20 20 28 69 66 20 28 70 72 65 64 (if (pred 5de0: 20 28 63 61 72 20 6c 69 73 29 29 0a 20 20 20 20 (car lis)). 5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5e10: 20 20 20 20 20 20 20 20 20 20 28 73 63 61 6e 2d (scan- 5e20: 69 6e 20 6c 69 73 20 28 63 64 72 20 6c 69 73 29 in lis (cdr lis) 5e30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 5e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5e60: 28 73 63 61 6e 2d 6f 75 74 20 70 72 65 76 20 28 (scan-out prev ( 5e70: 63 64 72 20 6c 69 73 29 29 29 29 29 29 0a 20 20 cdr lis)))))). 5e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5e90: 20 20 20 20 20 20 20 20 20 28 73 63 61 6e 2d 6f (scan-o 5ea0: 75 74 20 28 6c 61 6d 62 64 61 20 28 70 72 65 76 ut (lambda (prev 5eb0: 20 6c 69 73 29 0a 20 20 20 20 20 20 20 20 20 20 lis). 5ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 5ee0: 74 20 6c 70 20 28 28 6c 69 73 20 6c 69 73 29 29 t lp ((lis lis)) 5ef0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 5f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5f10: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 (if (p 5f20: 61 69 72 3f 20 6c 69 73 29 0a 20 20 20 20 20 20 air? lis). 5f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5f50: 20 20 20 20 20 20 20 28 69 66 20 28 70 72 65 64 (if (pred 5f60: 20 28 63 61 72 20 6c 69 73 29 29 0a 20 20 20 20 (car lis)). 5f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be 5fa0: 67 69 6e 20 28 73 65 74 2d 63 64 72 21 20 70 72 gin (set-cdr! pr 5fb0: 65 76 20 6c 69 73 29 0a 20 20 20 20 20 20 20 20 ev lis). 5fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 5ff0: 28 73 63 61 6e 2d 69 6e 20 6c 69 73 20 28 63 64 (scan-in lis (cd 6000: 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 20 20 r lis))). 6010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6030: 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 63 (lp (c 6040: 64 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 20 dr lis))). 6050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6070: 20 20 20 20 20 20 20 28 73 65 74 2d 63 64 72 21 (set-cdr! 6080: 20 70 72 65 76 20 6c 69 73 29 29 29 29 29 29 0a prev lis)))))). 6090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 60a0: 20 20 20 20 28 73 63 61 6e 2d 69 6e 20 61 6e 73 (scan-in ans 60b0: 20 28 63 64 72 20 61 6e 73 29 29 0a 20 20 20 20 (cdr ans)). 60c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 60d0: 61 6e 73 29 29 29 29 29 0a 0a 20 20 28 64 65 66 ans))))).. (def 60e0: 69 6e 65 20 28 70 61 72 74 69 74 69 6f 6e 20 70 ine (partition p 60f0: 72 65 64 20 6c 69 73 29 0a 20 20 20 20 28 63 68 red lis). (ch 6100: 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 eck-arg procedur 6110: 65 3f 20 70 72 65 64 20 70 61 72 74 69 74 69 6f e? pred partitio 6120: 6e 29 0a 20 20 20 20 28 6c 65 74 20 72 65 63 75 n). (let recu 6130: 72 20 28 28 6c 69 73 20 6c 69 73 29 29 0a 20 20 r ((lis lis)). 6140: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 (if (null-li 6150: 73 74 3f 20 6c 69 73 29 20 28 76 61 6c 75 65 73 st? lis) (values 6160: 20 6c 69 73 20 6c 69 73 29 09 3b 20 55 73 65 20 lis lis).; Use 6170: 4e 4f 54 2d 50 41 49 52 3f 20 74 6f 20 68 61 6e NOT-PAIR? to han 6180: 64 6c 65 20 64 6f 74 74 65 64 20 6c 69 73 74 73 dle dotted lists 6190: 2e 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 .. (let 61a0: 20 28 28 65 6c 74 20 28 63 61 72 20 6c 69 73 29 ((elt (car lis) 61b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 61c0: 20 20 28 74 61 69 6c 20 28 63 64 72 20 6c 69 73 (tail (cdr lis 61d0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 61e0: 28 72 65 63 65 69 76 65 20 28 69 6e 20 6f 75 74 (receive (in out 61f0: 29 20 28 72 65 63 75 72 20 74 61 69 6c 29 0a 20 ) (recur tail). 6200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6210: 20 20 20 20 28 69 66 20 28 70 72 65 64 20 65 6c (if (pred el 6220: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t). 6230: 20 20 20 20 20 20 20 20 20 20 20 20 28 76 61 6c (val 6240: 75 65 73 20 28 69 66 20 28 70 61 69 72 3f 20 6f ues (if (pair? o 6250: 75 74 29 20 28 63 6f 6e 73 20 65 6c 74 20 69 6e ut) (cons elt in 6260: 29 20 6c 69 73 29 20 6f 75 74 29 0a 20 20 20 20 ) lis) out). 6270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6280: 20 20 20 20 20 28 76 61 6c 75 65 73 20 69 6e 20 (values in 6290: 28 69 66 20 28 70 61 69 72 3f 20 69 6e 29 20 28 (if (pair? in) ( 62a0: 63 6f 6e 73 20 65 6c 74 20 6f 75 74 29 20 6c 69 cons elt out) li 62b0: 73 29 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 s)))))))).. (de 62c0: 66 69 6e 65 20 28 70 61 72 74 69 74 69 6f 6e 21 fine (partition! 62d0: 20 70 72 65 64 20 6c 69 73 29 0a 20 20 20 20 28 pred lis). ( 62e0: 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 check-arg proced 62f0: 75 72 65 3f 20 70 72 65 64 20 70 61 72 74 69 74 ure? pred partit 6300: 69 6f 6e 21 29 0a 20 20 20 20 28 69 66 20 28 6e ion!). (if (n 6310: 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 20 28 ull-list? lis) ( 6320: 76 61 6c 75 65 73 20 6c 69 73 20 6c 69 73 29 0a values lis lis). 6330: 20 20 20 20 20 20 20 20 28 6c 65 74 72 65 63 20 (letrec 6340: 28 28 73 63 61 6e 2d 69 6e 20 28 6c 61 6d 62 64 ((scan-in (lambd 6350: 61 20 28 69 6e 2d 70 72 65 76 20 6f 75 74 2d 70 a (in-prev out-p 6360: 72 65 76 20 6c 69 73 29 0a 20 20 20 20 20 20 20 rev lis). 6370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6380: 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 (let lp ((i 6390: 6e 2d 70 72 65 76 20 69 6e 2d 70 72 65 76 29 20 n-prev in-prev) 63a0: 28 6c 69 73 20 6c 69 73 29 29 0a 20 20 20 20 20 (lis lis)). 63b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63c0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 61 (if (pa 63d0: 69 72 3f 20 6c 69 73 29 0a 20 20 20 20 20 20 20 ir? lis). 63e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63f0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 6400: 70 72 65 64 20 28 63 61 72 20 6c 69 73 29 29 0a pred (car lis)). 6410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6430: 20 20 20 20 20 20 28 6c 70 20 6c 69 73 20 28 63 (lp lis (c 6440: 64 72 20 6c 69 73 29 29 0a 20 20 20 20 20 20 20 dr lis)). 6450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 6470: 62 65 67 69 6e 20 28 73 65 74 2d 63 64 72 21 20 begin (set-cdr! 6480: 6f 75 74 2d 70 72 65 76 20 6c 69 73 29 0a 20 20 out-prev lis). 6490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64b0: 20 20 20 20 20 20 20 20 20 20 20 28 73 63 61 6e (scan 64c0: 2d 6f 75 74 20 69 6e 2d 70 72 65 76 20 6c 69 73 -out in-prev lis 64d0: 20 28 63 64 72 20 6c 69 73 29 29 29 29 0a 20 20 (cdr lis)))). 64e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6500: 28 73 65 74 2d 63 64 72 21 20 6f 75 74 2d 70 72 (set-cdr! out-pr 6510: 65 76 20 6c 69 73 29 29 29 29 29 20 3b 20 44 6f ev lis))))) ; Do 6520: 6e 65 2e 0a 0a 20 20 20 20 20 20 20 20 20 20 20 ne... 6530: 20 20 20 20 20 20 28 73 63 61 6e 2d 6f 75 74 20 (scan-out 6540: 28 6c 61 6d 62 64 61 20 28 69 6e 2d 70 72 65 76 (lambda (in-prev 6550: 20 6f 75 74 2d 70 72 65 76 20 6c 69 73 29 0a 20 out-prev lis). 6560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6570: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let 6580: 20 6c 70 20 28 28 6f 75 74 2d 70 72 65 76 20 6f lp ((out-prev o 6590: 75 74 2d 70 72 65 76 29 20 28 6c 69 73 20 6c 69 ut-prev) (lis li 65a0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)). 65b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65c0: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 6c 69 (if (pair? li 65d0: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s). 65e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65f0: 20 20 20 20 20 20 28 69 66 20 28 70 72 65 64 20 (if (pred 6600: 28 63 61 72 20 6c 69 73 29 29 0a 20 20 20 20 20 (car lis)). 6610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6630: 20 20 28 62 65 67 69 6e 20 28 73 65 74 2d 63 64 (begin (set-cd 6640: 72 21 20 69 6e 2d 70 72 65 76 20 6c 69 73 29 0a r! in-prev lis). 6650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 6680: 63 61 6e 2d 69 6e 20 6c 69 73 20 6f 75 74 2d 70 can-in lis out-p 6690: 72 65 76 20 28 63 64 72 20 6c 69 73 29 29 29 0a rev (cdr lis))). 66a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66c0: 20 20 20 20 20 20 20 28 6c 70 20 6c 69 73 20 28 (lp lis ( 66d0: 63 64 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 cdr lis))). 66e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 6700: 65 74 2d 63 64 72 21 20 69 6e 2d 70 72 65 76 20 et-cdr! in-prev 6710: 6c 69 73 29 29 29 29 29 29 20 3b 20 44 6f 6e 65 lis)))))) ; Done 6720: 2e 0a 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ... ;; 6730: 43 72 61 6e 6b 20 75 70 20 74 68 65 20 73 63 61 Crank up the sca 6740: 6e 26 73 70 6c 69 63 65 20 6c 6f 6f 70 73 2e 0a n&splice loops.. 6750: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 (if (p 6760: 72 65 64 20 28 63 61 72 20 6c 69 73 29 29 0a 20 red (car lis)). 6770: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;; 6780: 4c 49 53 20 62 65 67 69 6e 73 20 69 6e 2d 6c 69 LIS begins in-li 6790: 73 74 2e 20 53 65 61 72 63 68 20 66 6f 72 20 6f st. Search for o 67a0: 75 74 2d 6c 69 73 74 27 73 20 66 69 72 73 74 20 ut-list's first 67b0: 70 61 69 72 2e 0a 20 20 20 20 20 20 20 20 20 20 pair.. 67c0: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 70 72 (let lp ((pr 67d0: 65 76 2d 6c 20 6c 69 73 29 20 28 6c 20 28 63 64 ev-l lis) (l (cd 67e0: 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 20 20 r lis))). 67f0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 28 (cond ( 6800: 28 6e 6f 74 20 28 70 61 69 72 3f 20 6c 29 29 20 (not (pair? l)) 6810: 28 76 61 6c 75 65 73 20 6c 69 73 20 6c 29 29 0a (values lis l)). 6820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6830: 20 20 20 20 20 20 28 28 70 72 65 64 20 28 63 61 ((pred (ca 6840: 72 20 6c 29 29 20 28 6c 70 20 6c 20 28 63 64 72 r l)) (lp l (cdr 6850: 20 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 l))). 6860: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els 6870: 65 20 28 73 63 61 6e 2d 6f 75 74 20 70 72 65 76 e (scan-out prev 6880: 2d 6c 20 6c 20 28 63 64 72 20 6c 29 29 0a 20 20 -l l (cdr l)). 6890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68a0: 20 20 20 20 20 20 20 20 20 20 28 76 61 6c 75 65 (value 68b0: 73 20 6c 69 73 20 6c 29 29 29 29 09 3b 20 44 6f s lis l)))).; Do 68c0: 6e 65 2e 0a 0a 20 20 20 20 20 20 20 20 20 20 20 ne... 68d0: 20 20 20 3b 3b 20 4c 49 53 20 62 65 67 69 6e 73 ;; LIS begins 68e0: 20 6f 75 74 2d 6c 69 73 74 2e 20 53 65 61 72 63 out-list. Searc 68f0: 68 20 66 6f 72 20 69 6e 2d 6c 69 73 74 27 73 20 h for in-list's 6900: 66 69 72 73 74 20 70 61 69 72 2e 0a 20 20 20 20 first pair.. 6910: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c (let l 6920: 70 20 28 28 70 72 65 76 2d 6c 20 6c 69 73 29 20 p ((prev-l lis) 6930: 28 6c 20 28 63 64 72 20 6c 69 73 29 29 29 0a 20 (l (cdr lis))). 6940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 6950: 63 6f 6e 64 20 28 28 6e 6f 74 20 28 70 61 69 72 cond ((not (pair 6960: 3f 20 6c 29 29 20 28 76 61 6c 75 65 73 20 6c 20 ? l)) (values l 6970: 6c 69 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 lis)). 6980: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 72 ((pr 6990: 65 64 20 28 63 61 72 20 6c 29 29 0a 20 20 20 20 ed (car l)). 69a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69b0: 20 20 20 28 73 63 61 6e 2d 69 6e 20 6c 20 70 72 (scan-in l pr 69c0: 65 76 2d 6c 20 28 63 64 72 20 6c 29 29 0a 20 20 ev-l (cdr l)). 69d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69e0: 20 20 20 20 20 28 76 61 6c 75 65 73 20 6c 20 6c (values l l 69f0: 69 73 29 29 09 09 3b 20 44 6f 6e 65 2e 0a 20 20 is))..; Done.. 6a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6a10: 20 20 20 20 28 65 6c 73 65 20 28 6c 70 20 6c 20 (else (lp l 6a20: 28 63 64 72 20 6c 29 29 29 29 29 29 29 29 29 0a (cdr l))))))))). 6a30: 0a 0a 20 20 3b 3b 20 49 6e 6c 69 6e 65 20 75 73 .. ;; Inline us 6a40: 2c 20 70 6c 65 61 73 65 2e 0a 20 20 28 64 65 66 , please.. (def 6a50: 69 6e 65 20 28 72 65 6d 6f 76 65 20 20 70 72 65 ine (remove pre 6a60: 64 20 6c 29 20 28 66 69 6c 74 65 72 20 20 28 6c d l) (filter (l 6a70: 61 6d 62 64 61 20 28 78 29 20 28 6e 6f 74 20 28 ambda (x) (not ( 6a80: 70 72 65 64 20 78 29 29 29 20 6c 29 29 0a 20 20 pred x))) l)). 6a90: 28 64 65 66 69 6e 65 20 28 72 65 6d 6f 76 65 21 (define (remove! 6aa0: 20 70 72 65 64 20 6c 29 20 28 66 69 6c 74 65 72 pred l) (filter 6ab0: 21 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 6e ! (lambda (x) (n 6ac0: 6f 74 20 28 70 72 65 64 20 78 29 29 29 20 6c 29 ot (pred x))) l) 6ad0: 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 64 65 6c ).. (define del 6ae0: 65 74 65 20 0a 20 20 20 20 28 63 61 73 65 2d 6c ete . (case-l 6af0: 61 6d 62 64 61 0a 20 20 20 20 20 5b 28 78 20 6c ambda. [(x l 6b00: 69 73 29 0a 20 20 20 20 20 20 28 64 65 6c 65 74 is). (delet 6b10: 65 20 78 20 6c 69 73 20 65 71 75 61 6c 3f 29 5d e x lis equal?)] 6b20: 0a 20 20 20 20 20 5b 28 78 20 6c 69 73 20 3d 29 . [(x lis =) 6b30: 20 0a 20 20 20 20 20 20 28 66 69 6c 74 65 72 20 . (filter 6b40: 28 6c 61 6d 62 64 61 20 28 79 29 20 28 6e 6f 74 (lambda (y) (not 6b50: 20 28 3d 20 78 20 79 29 29 29 20 6c 69 73 29 5d (= x y))) lis)] 6b60: 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 64 65 )).. (define de 6b70: 6c 65 74 65 21 20 0a 20 20 20 20 28 63 61 73 65 lete! . (case 6b80: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 5b 28 78 -lambda. [(x 6b90: 20 6c 69 73 29 0a 20 20 20 20 20 20 28 64 65 6c lis). (del 6ba0: 65 74 65 21 20 78 20 6c 69 73 20 65 71 75 61 6c ete! x lis equal 6bb0: 3f 29 5d 0a 20 20 20 20 20 5b 28 78 20 6c 69 73 ?)]. [(x lis 6bc0: 20 3d 29 0a 20 20 20 20 20 20 28 66 69 6c 74 65 =). (filte 6bd0: 72 21 20 28 6c 61 6d 62 64 61 20 28 79 29 20 28 r! (lambda (y) ( 6be0: 6e 6f 74 20 28 3d 20 78 20 79 29 29 29 20 6c 69 not (= x y))) li 6bf0: 73 29 5d 29 29 0a 0a 20 20 3b 3b 20 45 78 74 65 s)])).. ;; Exte 6c00: 6e 64 65 64 20 66 72 6f 6d 20 52 34 52 53 20 74 nded from R4RS t 6c10: 6f 20 74 61 6b 65 20 61 6e 20 6f 70 74 69 6f 6e o take an option 6c20: 61 6c 20 63 6f 6d 70 61 72 69 73 6f 6e 20 61 72 al comparison ar 6c30: 67 75 6d 65 6e 74 2e 0a 20 20 28 64 65 66 69 6e gument.. (defin 6c40: 65 20 6d 65 6d 62 65 72 20 20 0a 20 20 20 20 28 e member . ( 6c50: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda. 6c60: 20 5b 28 78 20 6c 69 73 29 0a 20 20 20 20 20 20 [(x lis). 6c70: 28 6d 65 6d 62 65 72 20 78 20 6c 69 73 20 65 71 (member x lis eq 6c80: 75 61 6c 3f 29 5d 0a 20 20 20 20 20 5b 28 78 20 ual?)]. [(x 6c90: 6c 69 73 20 3d 29 0a 20 20 20 20 20 20 28 66 69 lis =). (fi 6ca0: 6e 64 2d 74 61 69 6c 20 28 6c 61 6d 62 64 61 20 nd-tail (lambda 6cb0: 28 79 29 20 28 3d 20 78 20 79 29 29 20 6c 69 73 (y) (= x y)) lis 6cc0: 29 5d 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )])).. (define 6cd0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate 6ce0: 73 20 0a 20 20 20 20 28 63 61 73 65 2d 6c 61 6d s . (case-lam 6cf0: 62 64 61 0a 20 20 20 20 20 5b 28 6c 69 73 29 0a bda. [(lis). 6d00: 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d 64 75 (delete-du 6d10: 70 6c 69 63 61 74 65 73 20 6c 69 73 20 65 71 75 plicates lis equ 6d20: 61 6c 3f 29 5d 0a 20 20 20 20 20 5b 28 6c 69 73 al?)]. [(lis 6d30: 20 65 6c 74 3d 29 0a 20 20 20 20 20 20 28 63 68 elt=). (ch 6d40: 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 eck-arg procedur 6d50: 65 3f 20 65 6c 74 3d 20 64 65 6c 65 74 65 2d 64 e? elt= delete-d 6d60: 75 70 6c 69 63 61 74 65 73 29 0a 20 20 20 20 20 uplicates). 6d70: 20 28 6c 65 74 20 72 65 63 75 72 20 28 28 6c 69 (let recur ((li 6d80: 73 20 6c 69 73 29 29 0a 20 20 20 20 20 20 20 20 s lis)). 6d90: 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 (if (null-list? 6da0: 6c 69 73 29 20 6c 69 73 0a 20 20 20 20 20 20 20 lis) lis. 6db0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 78 20 28 (let* ((x ( 6dc0: 63 61 72 20 6c 69 73 29 29 0a 20 20 20 20 20 20 car lis)). 6dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 (ta 6de0: 69 6c 20 28 63 64 72 20 6c 69 73 29 29 0a 20 20 il (cdr lis)). 6df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e00: 20 28 6e 65 77 2d 74 61 69 6c 20 28 72 65 63 75 (new-tail (recu 6e10: 72 20 28 64 65 6c 65 74 65 20 78 20 74 61 69 6c r (delete x tail 6e20: 20 65 6c 74 3d 29 29 29 29 0a 20 20 20 20 20 20 elt=)))). 6e30: 20 20 20 20 20 20 20 20 28 69 66 20 28 65 71 3f (if (eq? 6e40: 20 74 61 69 6c 20 6e 65 77 2d 74 61 69 6c 29 20 tail new-tail) 6e50: 6c 69 73 20 28 63 6f 6e 73 20 78 20 6e 65 77 2d lis (cons x new- 6e60: 74 61 69 6c 29 29 29 29 29 5d 29 29 0a 0a 20 20 tail)))))])).. 6e70: 28 64 65 66 69 6e 65 20 64 65 6c 65 74 65 2d 64 (define delete-d 6e80: 75 70 6c 69 63 61 74 65 73 21 20 0a 20 20 20 20 uplicates! . 6e90: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda. 6ea0: 20 20 5b 28 6c 69 73 29 0a 20 20 20 20 20 20 28 [(lis). ( 6eb0: 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 delete-duplicate 6ec0: 73 21 20 6c 69 73 20 65 71 75 61 6c 3f 29 5d 0a s! lis equal?)]. 6ed0: 20 20 20 20 20 5b 28 6c 69 73 20 65 6c 74 3d 29 [(lis elt=) 6ee0: 0a 20 20 20 20 20 20 28 63 68 65 63 6b 2d 61 72 . (check-ar 6ef0: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 65 6c 74 g procedure? elt 6f00: 3d 20 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 = delete-duplica 6f10: 74 65 73 21 29 0a 20 20 20 20 20 20 28 6c 65 74 tes!). (let 6f20: 20 72 65 63 75 72 20 28 28 6c 69 73 20 6c 69 73 recur ((lis lis 6f30: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if ( 6f40: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 20 null-list? lis) 6f50: 6c 69 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 lis. 6f60: 28 6c 65 74 2a 20 28 28 78 20 28 63 61 72 20 6c (let* ((x (car l 6f70: 69 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 is)). 6f80: 20 20 20 20 20 20 20 20 28 74 61 69 6c 20 28 63 (tail (c 6f90: 64 72 20 6c 69 73 29 29 0a 20 20 20 20 20 20 20 dr lis)). 6fa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new 6fb0: 2d 74 61 69 6c 20 28 72 65 63 75 72 20 28 64 65 -tail (recur (de 6fc0: 6c 65 74 65 21 20 78 20 74 61 69 6c 20 65 6c 74 lete! x tail elt 6fd0: 3d 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 =)))). 6fe0: 20 20 20 20 28 77 68 65 6e 20 28 6e 6f 74 20 28 (when (not ( 6ff0: 65 71 3f 20 74 61 69 6c 20 6e 65 77 2d 74 61 69 eq? tail new-tai 7000: 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 l)). 7010: 20 20 20 20 28 73 65 74 2d 63 64 72 21 20 6c 69 (set-cdr! li 7020: 73 20 6e 65 77 2d 74 61 69 6c 29 29 0a 20 20 20 s new-tail)). 7030: 20 20 20 20 20 20 20 20 20 20 20 6c 69 73 29 29 lis)) 7040: 29 5d 29 29 0a 0a 0a 20 20 3b 3b 20 61 6c 69 73 )]))... ;; alis 7050: 74 20 73 74 75 66 66 0a 20 20 3b 3b 20 3b 3b 3b t stuff. ;; ;;; 7060: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 20 28 64 65 ;;;;;;;;;.. (de 7070: 66 69 6e 65 20 61 73 73 6f 63 20 0a 20 20 20 20 fine assoc . 7080: 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 (case-lambda. 7090: 20 20 5b 28 78 20 6c 69 73 29 0a 20 20 20 20 20 [(x lis). 70a0: 20 28 61 73 73 6f 63 20 78 20 6c 69 73 20 65 71 (assoc x lis eq 70b0: 75 61 6c 3f 29 5d 0a 20 20 20 20 20 5b 28 78 20 ual?)]. [(x 70c0: 6c 69 73 20 3d 29 0a 20 20 20 20 20 20 28 66 69 lis =). (fi 70d0: 6e 64 20 28 6c 61 6d 62 64 61 20 28 65 6e 74 72 nd (lambda (entr 70e0: 79 29 20 28 3d 20 78 20 28 63 61 72 20 65 6e 74 y) (= x (car ent 70f0: 72 79 29 29 29 20 6c 69 73 29 5d 29 29 0a 0a 20 ry))) lis)])).. 7100: 20 28 64 65 66 69 6e 65 20 28 61 6c 69 73 74 2d (define (alist- 7110: 63 6f 6e 73 20 6b 65 79 20 64 61 74 75 6d 20 61 cons key datum a 7120: 6c 69 73 74 29 20 28 63 6f 6e 73 20 28 63 6f 6e list) (cons (con 7130: 73 20 6b 65 79 20 64 61 74 75 6d 29 20 61 6c 69 s key datum) ali 7140: 73 74 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 st)).. (define 7150: 28 61 6c 69 73 74 2d 63 6f 70 79 20 61 6c 69 73 (alist-copy alis 7160: 74 29 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d t). (map (lam 7170: 62 64 61 20 28 65 6c 74 29 20 28 63 6f 6e 73 20 bda (elt) (cons 7180: 28 63 61 72 20 65 6c 74 29 20 28 63 64 72 20 65 (car elt) (cdr e 7190: 6c 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 61 lt))). a 71a0: 6c 69 73 74 29 29 0a 0a 20 20 28 64 65 66 69 6e list)).. (defin 71b0: 65 20 61 6c 69 73 74 2d 64 65 6c 65 74 65 20 0a e alist-delete . 71c0: 20 20 20 20 28 63 61 73 65 2d 6c 61 6d 62 64 61 (case-lambda 71d0: 0a 20 20 20 20 20 5b 28 6b 65 79 20 61 6c 69 73 . [(key alis 71e0: 74 29 0a 20 20 20 20 20 20 28 61 6c 69 73 74 2d t). (alist- 71f0: 64 65 6c 65 74 65 20 6b 65 79 20 61 6c 69 73 74 delete key alist 7200: 20 65 71 75 61 6c 3f 29 5d 0a 20 20 20 20 20 5b equal?)]. [ 7210: 28 6b 65 79 20 61 6c 69 73 74 20 3d 29 0a 20 20 (key alist =). 7220: 20 20 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d (filter (lam 7230: 62 64 61 20 28 65 6c 74 29 20 28 6e 6f 74 20 28 bda (elt) (not ( 7240: 3d 20 6b 65 79 20 28 63 61 72 20 65 6c 74 29 29 = key (car elt)) 7250: 29 29 20 61 6c 69 73 74 29 5d 29 29 0a 0a 20 20 )) alist)])).. 7260: 28 64 65 66 69 6e 65 20 61 6c 69 73 74 2d 64 65 (define alist-de 7270: 6c 65 74 65 21 20 0a 20 20 20 20 28 63 61 73 65 lete! . (case 7280: 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 5b 28 6b -lambda. [(k 7290: 65 79 20 61 6c 69 73 74 29 0a 20 20 20 20 20 20 ey alist). 72a0: 28 61 6c 69 73 74 2d 64 65 6c 65 74 65 21 20 6b (alist-delete! k 72b0: 65 79 20 61 6c 69 73 74 20 65 71 75 61 6c 3f 29 ey alist equal?) 72c0: 5d 0a 20 20 20 20 20 5b 28 6b 65 79 20 61 6c 69 ]. [(key ali 72d0: 73 74 20 3d 29 0a 20 20 20 20 20 20 28 66 69 6c st =). (fil 72e0: 74 65 72 21 20 28 6c 61 6d 62 64 61 20 28 65 6c ter! (lambda (el 72f0: 74 29 20 28 6e 6f 74 20 28 3d 20 6b 65 79 20 28 t) (not (= key ( 7300: 63 61 72 20 65 6c 74 29 29 29 29 20 61 6c 69 73 car elt)))) alis 7310: 74 29 5d 29 29 0a 0a 0a 20 20 3b 3b 20 66 69 6e t)]))... ;; fin 7320: 64 20 66 69 6e 64 2d 74 61 69 6c 20 74 61 6b 65 d find-tail take 7330: 2d 77 68 69 6c 65 20 64 72 6f 70 2d 77 68 69 6c -while drop-whil 7340: 65 20 73 70 61 6e 20 62 72 65 61 6b 20 61 6e 79 e span break any 7350: 20 65 76 65 72 79 20 6c 69 73 74 2d 69 6e 64 65 every list-inde 7360: 78 0a 20 20 3b 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 3b x. ;; ;;;;;;;;; 7370: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 7380: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 7390: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 73a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 20 ;;;;;;;;;;;;.. 73b0: 28 64 65 66 69 6e 65 20 28 66 69 6e 64 20 70 72 (define (find pr 73c0: 65 64 20 6c 69 73 74 29 0a 20 20 20 20 28 63 6f ed list). (co 73d0: 6e 64 20 28 28 66 69 6e 64 2d 74 61 69 6c 20 70 nd ((find-tail p 73e0: 72 65 64 20 6c 69 73 74 29 20 3d 3e 20 63 61 72 red list) => car 73f0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 ). (els 7400: 65 20 23 66 29 29 29 0a 0a 20 20 28 64 65 66 69 e #f))).. (defi 7410: 6e 65 20 28 66 69 6e 64 2d 74 61 69 6c 20 70 72 ne (find-tail pr 7420: 65 64 20 6c 69 73 74 29 0a 20 20 20 20 28 63 68 ed list). (ch 7430: 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 eck-arg procedur 7440: 65 3f 20 70 72 65 64 20 66 69 6e 64 2d 74 61 69 e? pred find-tai 7450: 6c 29 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 l). (let lp ( 7460: 28 6c 69 73 74 20 6c 69 73 74 29 29 0a 20 20 20 (list list)). 7470: 20 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 (and (not (nu 7480: 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 74 29 29 0a ll-list? list)). 7490: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 74a0: 70 72 65 64 20 28 63 61 72 20 6c 69 73 74 29 29 pred (car list)) 74b0: 20 6c 69 73 74 0a 20 20 20 20 20 20 20 20 20 20 list. 74c0: 20 20 20 20 20 28 6c 70 20 28 63 64 72 20 6c 69 (lp (cdr li 74d0: 73 74 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 st)))))).. (def 74e0: 69 6e 65 20 28 74 61 6b 65 2d 77 68 69 6c 65 20 ine (take-while 74f0: 70 72 65 64 20 6c 69 73 29 0a 20 20 20 20 28 63 pred lis). (c 7500: 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 heck-arg procedu 7510: 72 65 3f 20 70 72 65 64 20 74 61 6b 65 2d 77 68 re? pred take-wh 7520: 69 6c 65 29 0a 20 20 20 20 28 6c 65 74 20 72 65 ile). (let re 7530: 63 75 72 20 28 28 6c 69 73 20 6c 69 73 29 29 0a cur ((lis lis)). 7540: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d (if (null- 7550: 6c 69 73 74 3f 20 6c 69 73 29 20 27 28 29 0a 20 list? lis) '(). 7560: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let (( 7570: 78 20 28 63 61 72 20 6c 69 73 29 29 29 0a 20 20 x (car lis))). 7580: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 (if (p 7590: 72 65 64 20 78 29 0a 20 20 20 20 20 20 20 20 20 red x). 75a0: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 78 20 28 (cons x ( 75b0: 72 65 63 75 72 20 28 63 64 72 20 6c 69 73 29 29 recur (cdr lis)) 75c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 75d0: 20 20 27 28 29 29 29 29 29 29 0a 0a 20 20 28 64 '()))))).. (d 75e0: 65 66 69 6e 65 20 28 64 72 6f 70 2d 77 68 69 6c efine (drop-whil 75f0: 65 20 70 72 65 64 20 6c 69 73 29 0a 20 20 20 20 e pred lis). 7600: 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 (check-arg proce 7610: 64 75 72 65 3f 20 70 72 65 64 20 64 72 6f 70 2d dure? pred drop- 7620: 77 68 69 6c 65 29 0a 20 20 20 20 28 6c 65 74 20 while). (let 7630: 6c 70 20 28 28 6c 69 73 20 6c 69 73 29 29 0a 20 lp ((lis lis)). 7640: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 2d 6c (if (null-l 7650: 69 73 74 3f 20 6c 69 73 29 20 27 28 29 0a 20 20 ist? lis) '(). 7660: 20 20 20 20 20 20 20 20 28 69 66 20 28 70 72 65 (if (pre 7670: 64 20 28 63 61 72 20 6c 69 73 29 29 0a 20 20 20 d (car lis)). 7680: 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 (lp ( 7690: 63 64 72 20 6c 69 73 29 29 0a 20 20 20 20 20 20 cdr lis)). 76a0: 20 20 20 20 20 20 20 20 6c 69 73 29 29 29 29 0a lis)))). 76b0: 0a 20 20 28 64 65 66 69 6e 65 20 28 74 61 6b 65 . (define (take 76c0: 2d 77 68 69 6c 65 21 20 70 72 65 64 20 6c 69 73 -while! pred lis 76d0: 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 ). (check-arg 76e0: 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 65 64 procedure? pred 76f0: 20 74 61 6b 65 2d 77 68 69 6c 65 21 29 0a 20 20 take-while!). 7700: 20 20 28 69 66 20 28 6f 72 20 28 6e 75 6c 6c 2d (if (or (null- 7710: 6c 69 73 74 3f 20 6c 69 73 29 20 28 6e 6f 74 20 list? lis) (not 7720: 28 70 72 65 64 20 28 63 61 72 20 6c 69 73 29 29 (pred (car lis)) 7730: 29 29 20 27 28 29 0a 20 20 20 20 20 20 20 20 28 )) '(). ( 7740: 62 65 67 69 6e 20 28 6c 65 74 20 6c 70 20 28 28 begin (let lp (( 7750: 70 72 65 76 20 6c 69 73 29 20 28 72 65 73 74 20 prev lis) (rest 7760: 28 63 64 72 20 6c 69 73 29 29 29 0a 20 20 20 20 (cdr lis))). 7770: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 7780: 20 28 70 61 69 72 3f 20 72 65 73 74 29 0a 20 20 (pair? rest). 7790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77a0: 20 20 20 28 6c 65 74 20 28 28 78 20 28 63 61 72 (let ((x (car 77b0: 20 72 65 73 74 29 29 29 0a 20 20 20 20 20 20 20 rest))). 77c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77d0: 28 69 66 20 28 70 72 65 64 20 78 29 20 28 6c 70 (if (pred x) (lp 77e0: 20 72 65 73 74 20 28 63 64 72 20 72 65 73 74 29 rest (cdr rest) 77f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 7800: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se 7810: 74 2d 63 64 72 21 20 70 72 65 76 20 27 28 29 29 t-cdr! prev '()) 7820: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 7830: 20 20 20 20 6c 69 73 29 29 29 0a 0a 20 20 28 64 lis))).. (d 7840: 65 66 69 6e 65 20 28 73 70 61 6e 20 70 72 65 64 efine (span pred 7850: 20 6c 69 73 29 0a 20 20 20 20 28 63 68 65 63 6b lis). (check 7860: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 7870: 70 72 65 64 20 73 70 61 6e 29 0a 20 20 20 20 28 pred span). ( 7880: 6c 65 74 20 72 65 63 75 72 20 28 28 6c 69 73 20 let recur ((lis 7890: 6c 69 73 29 29 0a 20 20 20 20 20 20 28 69 66 20 lis)). (if 78a0: 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 (null-list? lis) 78b0: 20 28 76 61 6c 75 65 73 20 27 28 29 20 27 28 29 (values '() '() 78c0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let 78d0: 20 28 28 78 20 28 63 61 72 20 6c 69 73 29 29 29 ((x (car lis))) 78e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if 78f0: 20 28 70 72 65 64 20 78 29 0a 20 20 20 20 20 20 (pred x). 7900: 20 20 20 20 20 20 20 20 20 20 28 72 65 63 65 69 (recei 7910: 76 65 20 28 70 72 65 66 69 78 20 73 75 66 66 69 ve (prefix suffi 7920: 78 29 20 28 72 65 63 75 72 20 28 63 64 72 20 6c x) (recur (cdr l 7930: 69 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 is)). 7940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 (v 7950: 61 6c 75 65 73 20 28 63 6f 6e 73 20 78 20 70 72 alues (cons x pr 7960: 65 66 69 78 29 20 73 75 66 66 69 78 29 29 0a 20 efix) suffix)). 7970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 7980: 76 61 6c 75 65 73 20 27 28 29 20 6c 69 73 29 29 values '() lis)) 7990: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 79a0: 28 73 70 61 6e 21 20 70 72 65 64 20 6c 69 73 29 (span! pred lis) 79b0: 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 . (check-arg 79c0: 70 72 6f 63 65 64 75 72 65 3f 20 70 72 65 64 20 procedure? pred 79d0: 73 70 61 6e 21 29 0a 20 20 20 20 28 69 66 20 28 span!). (if ( 79e0: 6f 72 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c or (null-list? l 79f0: 69 73 29 20 28 6e 6f 74 20 28 70 72 65 64 20 28 is) (not (pred ( 7a00: 63 61 72 20 6c 69 73 29 29 29 29 20 28 76 61 6c car lis)))) (val 7a10: 75 65 73 20 27 28 29 20 6c 69 73 29 0a 20 20 20 ues '() lis). 7a20: 20 20 20 20 20 28 6c 65 74 20 28 28 73 75 66 66 (let ((suff 7a30: 69 78 20 28 6c 65 74 20 6c 70 20 28 28 70 72 65 ix (let lp ((pre 7a40: 76 20 6c 69 73 29 20 28 72 65 73 74 20 28 63 64 v lis) (rest (cd 7a50: 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 20 20 r lis))). 7a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7a70: 20 28 69 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f (if (null-list? 7a80: 20 72 65 73 74 29 20 72 65 73 74 0a 20 20 20 20 rest) rest. 7a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7aa0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 78 (let ((x 7ab0: 20 28 63 61 72 20 72 65 73 74 29 29 29 0a 20 20 (car rest))). 7ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7ad0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 7ae0: 28 70 72 65 64 20 78 29 20 28 6c 70 20 72 65 73 (pred x) (lp res 7af0: 74 20 28 63 64 72 20 72 65 73 74 29 29 0a 20 20 t (cdr rest)). 7b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7b20: 28 62 65 67 69 6e 20 28 73 65 74 2d 63 64 72 21 (begin (set-cdr! 7b30: 20 70 72 65 76 20 27 28 29 29 0a 20 20 20 20 20 prev '()). 7b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7b60: 20 20 20 20 72 65 73 74 29 29 29 29 29 29 29 0a rest))))))). 7b70: 20 20 20 20 20 20 20 20 20 20 28 76 61 6c 75 65 (value 7b80: 73 20 6c 69 73 20 73 75 66 66 69 78 29 29 29 29 s lis suffix)))) 7b90: 0a 20 20 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 . .. (define ( 7ba0: 62 72 65 61 6b 20 20 70 72 65 64 20 6c 69 73 29 break pred lis) 7bb0: 20 28 73 70 61 6e 20 20 28 6c 61 6d 62 64 61 20 (span (lambda 7bc0: 28 78 29 20 28 6e 6f 74 20 28 70 72 65 64 20 78 (x) (not (pred x 7bd0: 29 29 29 20 6c 69 73 29 29 0a 20 20 28 64 65 66 ))) lis)). (def 7be0: 69 6e 65 20 28 62 72 65 61 6b 21 20 70 72 65 64 ine (break! pred 7bf0: 20 6c 69 73 29 20 28 73 70 61 6e 21 20 28 6c 61 lis) (span! (la 7c00: 6d 62 64 61 20 28 78 29 20 28 6e 6f 74 20 28 70 mbda (x) (not (p 7c10: 72 65 64 20 78 29 29 29 20 6c 69 73 29 29 0a 0a red x))) lis)).. 7c20: 20 20 28 64 65 66 69 6e 65 20 28 61 6e 79 20 70 (define (any p 7c30: 72 65 64 20 6c 69 73 31 20 2e 20 6c 69 73 74 73 red lis1 . lists 7c40: 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 ). (check-arg 7c50: 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 65 64 procedure? pred 7c60: 20 61 6e 79 29 0a 20 20 20 20 28 69 66 20 28 70 any). (if (p 7c70: 61 69 72 3f 20 6c 69 73 74 73 29 0a 0a 20 20 20 air? lists).. 7c80: 20 20 20 20 20 3b 3b 20 4e 2d 61 72 79 20 63 61 ;; N-ary ca 7c90: 73 65 0a 20 20 20 20 20 20 20 20 28 72 65 63 65 se. (rece 7ca0: 69 76 65 20 28 68 65 61 64 73 20 74 61 69 6c 73 ive (heads tails 7cb0: 29 20 28 25 63 61 72 73 2b 63 64 72 73 20 28 63 ) (%cars+cdrs (c 7cc0: 6f 6e 73 20 6c 69 73 31 20 6c 69 73 74 73 29 29 ons lis1 lists)) 7cd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 7ce0: 20 20 28 61 6e 64 20 28 70 61 69 72 3f 20 68 65 (and (pair? he 7cf0: 61 64 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 ads). 7d00: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let 7d10: 6c 70 20 28 28 68 65 61 64 73 20 68 65 61 64 73 lp ((heads heads 7d20: 29 20 28 74 61 69 6c 73 20 74 61 69 6c 73 29 29 ) (tails tails)) 7d30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 7d40: 20 20 20 20 20 20 20 20 20 28 72 65 63 65 69 76 (receiv 7d50: 65 20 28 6e 65 78 74 2d 68 65 61 64 73 20 6e 65 e (next-heads ne 7d60: 78 74 2d 74 61 69 6c 73 29 20 28 25 63 61 72 73 xt-tails) (%cars 7d70: 2b 63 64 72 73 20 74 61 69 6c 73 29 0a 20 20 20 +cdrs tails). 7d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 7da0: 66 20 28 70 61 69 72 3f 20 6e 65 78 74 2d 68 65 f (pair? next-he 7db0: 61 64 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 ads). 7dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7dd0: 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 (or (a 7de0: 70 70 6c 79 20 70 72 65 64 20 68 65 61 64 73 29 pply pred heads) 7df0: 20 28 6c 70 20 6e 65 78 74 2d 68 65 61 64 73 20 (lp next-heads 7e00: 6e 65 78 74 2d 74 61 69 6c 73 29 29 0a 20 20 20 next-tails)). 7e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7e30: 20 20 28 61 70 70 6c 79 20 70 72 65 64 20 68 65 (apply pred he 7e40: 61 64 73 29 29 29 29 29 29 20 3b 20 4c 61 73 74 ads)))))) ; Last 7e50: 20 50 52 45 44 20 61 70 70 20 69 73 20 74 61 69 PRED app is tai 7e60: 6c 20 63 61 6c 6c 2e 0a 0a 20 20 20 20 20 20 20 l call... 7e70: 20 3b 3b 20 46 61 73 74 20 70 61 74 68 0a 20 20 ;; Fast path. 7e80: 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f 74 20 (and (not 7e90: 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 31 (null-list? lis1 7ea0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 7eb0: 28 6c 65 74 20 6c 70 20 28 28 68 65 61 64 20 28 (let lp ((head ( 7ec0: 63 61 72 20 6c 69 73 31 29 29 20 28 74 61 69 6c car lis1)) (tail 7ed0: 20 28 63 64 72 20 6c 69 73 31 29 29 29 0a 20 20 (cdr lis1))). 7ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 7ef0: 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 74 61 69 (null-list? tai 7f00: 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 l). 7f10: 20 20 20 20 20 20 28 70 72 65 64 20 68 65 61 64 (pred head 7f20: 29 09 09 3b 20 4c 61 73 74 20 50 52 45 44 20 61 )..; Last PRED a 7f30: 70 70 20 69 73 20 74 61 69 6c 20 63 61 6c 6c 2e pp is tail call. 7f40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 7f50: 20 20 20 20 28 6f 72 20 28 70 72 65 64 20 68 65 (or (pred he 7f60: 61 64 29 20 28 6c 70 20 28 63 61 72 20 74 61 69 ad) (lp (car tai 7f70: 6c 29 20 28 63 64 72 20 74 61 69 6c 29 29 29 29 l) (cdr tail)))) 7f80: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 7f90: 65 76 65 72 79 0a 20 20 20 20 28 63 61 73 65 2d every. (case- 7fa0: 6c 61 6d 62 64 61 0a 20 20 20 20 20 5b 28 70 20 lambda. [(p 7fb0: 6c 73 29 20 0a 20 20 20 20 20 20 28 6f 72 20 28 ls) . (or ( 7fc0: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 73 29 0a 20 null-list? ls). 7fd0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 66 20 (let f 7fe0: 28 5b 70 20 70 5d 20 5b 61 20 28 63 61 72 20 6c ([p p] [a (car l 7ff0: 73 29 5d 20 5b 64 20 28 63 64 72 20 6c 73 29 5d s)] [d (cdr ls)] 8000: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ). (c 8010: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond. 8020: 20 5b 28 70 61 69 72 3f 20 64 29 20 0a 20 20 20 [(pair? d) . 8030: 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 (and 8040: 28 70 20 61 29 20 28 66 20 70 20 28 63 61 72 20 (p a) (f p (car 8050: 64 29 20 28 63 64 72 20 64 29 29 29 5d 0a 20 20 d) (cdr d)))]. 8060: 20 20 20 20 20 20 20 20 20 20 20 5b 65 6c 73 65 [else 8070: 20 28 70 20 61 29 5d 29 29 29 5d 0a 20 20 20 20 (p a)])))]. 8080: 20 5b 28 70 20 6c 73 31 20 6c 73 32 29 0a 20 20 [(p ls1 ls2). 8090: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond. 80a0: 20 5b 28 61 6e 64 20 28 70 61 69 72 3f 20 6c 73 [(and (pair? ls 80b0: 31 29 20 28 70 61 69 72 3f 20 6c 73 32 29 29 20 1) (pair? ls2)) 80c0: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 66 20 . (let f 80d0: 28 5b 70 20 70 5d 20 5b 61 31 20 28 63 61 72 20 ([p p] [a1 (car 80e0: 6c 73 31 29 5d 20 5b 64 31 20 28 63 64 72 20 6c ls1)] [d1 (cdr l 80f0: 73 31 29 5d 20 5b 61 32 20 28 63 61 72 20 6c 73 s1)] [a2 (car ls 8100: 32 29 5d 20 5b 64 32 20 28 63 64 72 20 6c 73 32 2)] [d2 (cdr ls2 8110: 29 5d 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 )]). (c 8120: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 5b ond. [ 8130: 28 61 6e 64 20 28 70 61 69 72 3f 20 64 31 29 20 (and (pair? d1) 8140: 28 70 61 69 72 3f 20 64 32 29 29 20 0a 20 20 20 (pair? d2)) . 8150: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 70 (and (p 8160: 20 61 31 20 61 32 29 20 28 66 20 70 20 28 63 61 a1 a2) (f p (ca 8170: 72 20 64 31 29 20 28 63 64 72 20 64 31 29 20 28 r d1) (cdr d1) ( 8180: 63 61 72 20 64 32 29 20 28 63 64 72 20 64 32 29 car d2) (cdr d2) 8190: 29 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b ))]. [ 81a0: 65 6c 73 65 20 28 70 20 61 31 20 61 32 29 5d 29 else (p a1 a2)]) 81b0: 29 5d 0a 20 20 20 20 20 20 20 5b 65 6c 73 65 20 )]. [else 81c0: 23 74 5d 29 5d 0a 20 20 20 20 20 5b 28 70 72 65 #t])]. [(pre 81d0: 64 20 6c 69 73 31 20 2e 20 6c 69 73 74 73 29 0a d lis1 . lists). 81e0: 20 20 20 20 20 20 28 72 65 63 65 69 76 65 20 28 (receive ( 81f0: 68 65 61 64 73 20 74 61 69 6c 73 29 20 28 25 63 heads tails) (%c 8200: 61 72 73 2b 63 64 72 73 20 28 63 6f 6e 73 20 6c ars+cdrs (cons l 8210: 69 73 31 20 6c 69 73 74 73 29 29 0a 20 20 20 20 is1 lists)). 8220: 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 (or ( 8230: 6e 6f 74 20 28 70 61 69 72 3f 20 68 65 61 64 73 not (pair? heads 8240: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 8250: 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 (let lp (( 8260: 68 65 61 64 73 20 68 65 61 64 73 29 20 28 74 61 heads heads) (ta 8270: 69 6c 73 20 74 61 69 6c 73 29 29 0a 20 20 20 20 ils tails)). 8280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8290: 20 28 72 65 63 65 69 76 65 20 28 6e 65 78 74 2d (receive (next- 82a0: 68 65 61 64 73 20 6e 65 78 74 2d 74 61 69 6c 73 heads next-tails 82b0: 29 20 28 25 63 61 72 73 2b 63 64 72 73 20 74 61 ) (%cars+cdrs ta 82c0: 69 6c 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 ils). 82d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 82e0: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 6e 65 (if (pair? ne 82f0: 78 74 2d 68 65 61 64 73 29 0a 20 20 20 20 20 20 xt-heads). 8300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8310: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 (and 8320: 20 28 61 70 70 6c 79 20 70 72 65 64 20 68 65 61 (apply pred hea 8330: 64 73 29 20 28 6c 70 20 6e 65 78 74 2d 68 65 61 ds) (lp next-hea 8340: 64 73 20 6e 65 78 74 2d 74 61 69 6c 73 29 29 0a ds next-tails)). 8350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8370: 20 20 28 61 70 70 6c 79 20 70 72 65 64 20 68 65 (apply pred he 8380: 61 64 73 29 29 29 29 29 29 5d 29 29 0a 0a 20 20 ads))))))])).. 8390: 28 64 65 66 69 6e 65 20 28 6c 69 73 74 2d 69 6e (define (list-in 83a0: 64 65 78 20 70 72 65 64 20 6c 69 73 31 20 2e 20 dex pred lis1 . 83b0: 6c 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 lists). (chec 83c0: 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f k-arg procedure? 83d0: 20 70 72 65 64 20 6c 69 73 74 2d 69 6e 64 65 78 pred list-index 83e0: 29 0a 20 20 20 20 28 69 66 20 28 70 61 69 72 3f ). (if (pair? 83f0: 20 6c 69 73 74 73 29 0a 0a 20 20 20 20 20 20 20 lists).. 8400: 20 3b 3b 20 4e 2d 61 72 79 20 63 61 73 65 0a 20 ;; N-ary case. 8410: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 (let lp ( 8420: 28 6c 69 73 74 73 20 28 63 6f 6e 73 20 6c 69 73 (lists (cons lis 8430: 31 20 6c 69 73 74 73 29 29 20 28 6e 20 30 29 29 1 lists)) (n 0)) 8440: 0a 20 20 20 20 20 20 20 20 20 20 28 72 65 63 65 . (rece 8450: 69 76 65 20 28 68 65 61 64 73 20 74 61 69 6c 73 ive (heads tails 8460: 29 20 28 25 63 61 72 73 2b 63 64 72 73 20 6c 69 ) (%cars+cdrs li 8470: 73 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 sts). 8480: 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 70 61 (and (pa 8490: 69 72 3f 20 68 65 61 64 73 29 0a 20 20 20 20 20 ir? heads). 84a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 84b0: 20 20 20 28 69 66 20 28 61 70 70 6c 79 20 70 72 (if (apply pr 84c0: 65 64 20 68 65 61 64 73 29 20 6e 0a 20 20 20 20 ed heads) n. 84d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 84e0: 20 20 20 20 20 20 20 20 28 6c 70 20 74 61 69 6c (lp tail 84f0: 73 20 28 2b 20 6e 20 31 29 29 29 29 29 29 0a 0a s (+ n 1)))))).. 8500: 20 20 20 20 20 20 20 20 3b 3b 20 46 61 73 74 20 ;; Fast 8510: 70 61 74 68 0a 20 20 20 20 20 20 20 20 28 6c 65 path. (le 8520: 74 20 6c 70 20 28 28 6c 69 73 20 6c 69 73 31 29 t lp ((lis lis1) 8530: 20 28 6e 20 30 29 29 0a 20 20 20 20 20 20 20 20 (n 0)). 8540: 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c (and (not (nul 8550: 6c 2d 6c 69 73 74 3f 20 6c 69 73 29 29 0a 20 20 l-list? lis)). 8560: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 8570: 20 28 70 72 65 64 20 28 63 61 72 20 6c 69 73 29 (pred (car lis) 8580: 29 20 6e 20 28 6c 70 20 28 63 64 72 20 6c 69 73 ) n (lp (cdr lis 8590: 29 20 28 2b 20 6e 20 31 29 29 29 29 29 29 29 0a ) (+ n 1))))))). 85a0: 0a 20 20 3b 3b 20 52 65 76 65 72 73 65 0a 20 20 . ;; Reverse. 85b0: 3b 3b 20 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 20 28 ;; ;;;;;;;;.. ( 85c0: 64 65 66 69 6e 65 20 28 72 65 76 65 72 73 65 21 define (reverse! 85d0: 20 6c 69 73 29 0a 20 20 20 20 28 6c 65 74 20 6c lis). (let l 85e0: 70 20 28 28 6c 69 73 20 6c 69 73 29 20 28 61 6e p ((lis lis) (an 85f0: 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 28 69 s '())). (i 8600: 66 20 28 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 f (null-list? li 8610: 73 29 20 61 6e 73 0a 20 20 20 20 20 20 20 20 20 s) ans. 8620: 20 28 6c 65 74 20 28 28 74 61 69 6c 20 28 63 64 (let ((tail (cd 8630: 72 20 6c 69 73 29 29 29 0a 20 20 20 20 20 20 20 r lis))). 8640: 20 20 20 20 20 28 73 65 74 2d 63 64 72 21 20 6c (set-cdr! l 8650: 69 73 20 61 6e 73 29 0a 20 20 20 20 20 20 20 20 is ans). 8660: 20 20 20 20 28 6c 70 20 74 61 69 6c 20 6c 69 73 (lp tail lis 8670: 29 29 29 29 29 0a 0a 20 20 3b 3b 20 4c 69 73 74 ))))).. ;; List 8680: 73 2d 61 73 2d 73 65 74 73 0a 20 20 3b 3b 20 3b s-as-sets. ;; ; 8690: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 20 ;;;;;;;;;;;;;.. 86a0: 20 28 64 65 66 69 6e 65 20 28 25 6c 73 65 74 32 (define (%lset2 86b0: 3c 3d 20 3d 20 6c 69 73 31 20 6c 69 73 32 29 20 <= = lis1 lis2) 86c0: 28 65 76 65 72 79 20 28 6c 61 6d 62 64 61 20 28 (every (lambda ( 86d0: 78 29 20 28 6d 65 6d 62 65 72 20 78 20 6c 69 73 x) (member x lis 86e0: 32 20 3d 29 29 20 6c 69 73 31 29 29 0a 0a 20 20 2 =)) lis1)).. 86f0: 28 64 65 66 69 6e 65 20 28 6c 73 65 74 3c 3d 20 (define (lset<= 8700: 3d 20 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 = . lists). ( 8710: 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 check-arg proced 8720: 75 72 65 3f 20 3d 20 6c 73 65 74 3c 3d 29 0a 20 ure? = lset<=). 8730: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 70 61 69 (or (not (pai 8740: 72 3f 20 6c 69 73 74 73 29 29 20 3b 20 30 2d 61 r? lists)) ; 0-a 8750: 72 79 20 63 61 73 65 0a 20 20 20 20 20 20 20 20 ry case. 8760: 28 6c 65 74 20 6c 70 20 28 28 73 31 20 28 63 61 (let lp ((s1 (ca 8770: 72 20 6c 69 73 74 73 29 29 20 28 72 65 73 74 20 r lists)) (rest 8780: 28 63 64 72 20 6c 69 73 74 73 29 29 29 0a 20 20 (cdr lists))). 8790: 20 20 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 (or (not 87a0: 20 28 70 61 69 72 3f 20 72 65 73 74 29 29 0a 20 (pair? rest)). 87b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le 87c0: 74 20 28 28 73 32 20 28 63 61 72 20 72 65 73 74 t ((s2 (car rest 87d0: 29 29 20 20 28 72 65 73 74 20 28 63 64 72 20 72 )) (rest (cdr r 87e0: 65 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 est))). 87f0: 20 20 20 20 20 20 20 28 61 6e 64 20 28 6f 72 20 (and (or 8800: 28 65 71 3f 20 73 32 20 73 31 29 09 3b 20 46 61 (eq? s2 s1).; Fa 8810: 73 74 20 70 61 74 68 0a 20 20 20 20 20 20 20 20 st path. 8820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8830: 20 28 25 6c 73 65 74 32 3c 3d 20 3d 20 73 31 20 (%lset2<= = s1 8840: 73 32 29 29 20 3b 20 52 65 61 6c 20 74 65 73 74 s2)) ; Real test 8850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 8860: 20 20 20 20 20 20 28 6c 70 20 73 32 20 72 65 73 (lp s2 res 8870: 74 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 t))))))).. (def 8880: 69 6e 65 20 28 6c 73 65 74 3d 20 3d 20 2e 20 6c ine (lset= = . l 8890: 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b ists). (check 88a0: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 88b0: 3d 20 6c 73 65 74 3d 29 0a 20 20 20 20 28 6f 72 = lset=). (or 88c0: 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 6c 69 73 (not (pair? lis 88d0: 74 73 29 29 20 3b 20 30 2d 61 72 79 20 63 61 73 ts)) ; 0-ary cas 88e0: 65 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c e. (let l 88f0: 70 20 28 28 73 31 20 28 63 61 72 20 6c 69 73 74 p ((s1 (car list 8900: 73 29 29 20 28 72 65 73 74 20 28 63 64 72 20 6c s)) (rest (cdr l 8910: 69 73 74 73 29 29 29 0a 20 20 20 20 20 20 20 20 ists))). 8920: 20 20 28 6f 72 20 28 6e 6f 74 20 28 70 61 69 72 (or (not (pair 8930: 3f 20 72 65 73 74 29 29 0a 20 20 20 20 20 20 20 ? rest)). 8940: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 32 (let ((s2 8950: 20 20 20 28 63 61 72 20 72 65 73 74 29 29 0a 20 (car rest)). 8960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8970: 20 20 20 28 72 65 73 74 20 28 63 64 72 20 72 65 (rest (cdr re 8980: 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 st))). 8990: 20 20 20 20 20 20 28 61 6e 64 20 28 6f 72 20 28 (and (or ( 89a0: 65 71 3f 20 73 31 20 73 32 29 09 3b 20 46 61 73 eq? s1 s2).; Fas 89b0: 74 20 70 61 74 68 0a 20 20 20 20 20 20 20 20 20 t path. 89c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 89d0: 28 61 6e 64 20 28 25 6c 73 65 74 32 3c 3d 20 3d (and (%lset2<= = 89e0: 20 73 31 20 73 32 29 20 28 25 6c 73 65 74 32 3c s1 s2) (%lset2< 89f0: 3d 20 3d 20 73 32 20 73 31 29 29 29 20 3b 20 52 = = s2 s1))) ; R 8a00: 65 61 6c 20 74 65 73 74 0a 20 20 20 20 20 20 20 eal test. 8a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 8a20: 70 20 73 32 20 72 65 73 74 29 29 29 29 29 29 29 p s2 rest))))))) 8a30: 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 73 ... (define (ls 8a40: 65 74 2d 61 64 6a 6f 69 6e 20 3d 20 6c 69 73 20 et-adjoin = lis 8a50: 2e 20 65 6c 74 73 29 0a 20 20 20 20 28 63 68 65 . elts). (che 8a60: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure 8a70: 3f 20 3d 20 6c 73 65 74 2d 61 64 6a 6f 69 6e 29 ? = lset-adjoin) 8a80: 0a 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 . (fold (lamb 8a90: 64 61 20 28 65 6c 74 20 61 6e 73 29 20 28 69 66 da (elt ans) (if 8aa0: 20 28 6d 65 6d 62 65 72 20 65 6c 74 20 61 6e 73 (member elt ans 8ab0: 20 3d 29 20 61 6e 73 20 28 63 6f 6e 73 20 65 6c =) ans (cons el 8ac0: 74 20 61 6e 73 29 29 29 0a 20 20 20 20 20 20 20 t ans))). 8ad0: 20 20 20 6c 69 73 20 65 6c 74 73 29 29 0a 0a 0a lis elts))... 8ae0: 20 20 28 64 65 66 69 6e 65 20 28 6c 73 65 74 2d (define (lset- 8af0: 75 6e 69 6f 6e 20 3d 20 2e 20 6c 69 73 74 73 29 union = . lists) 8b00: 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 . (check-arg 8b10: 70 72 6f 63 65 64 75 72 65 3f 20 3d 20 6c 73 65 procedure? = lse 8b20: 74 2d 75 6e 69 6f 6e 29 0a 20 20 20 20 28 72 65 t-union). (re 8b30: 64 75 63 65 20 28 6c 61 6d 62 64 61 20 28 6c 69 duce (lambda (li 8b40: 73 20 61 6e 73 29 09 09 3b 20 43 6f 6d 70 75 74 s ans)..; Comput 8b50: 65 20 41 4e 53 20 2b 20 4c 49 53 2e 0a 20 20 20 e ANS + LIS.. 8b60: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond 8b70: 20 28 28 6e 75 6c 6c 3f 20 6c 69 73 29 20 61 6e ((null? lis) an 8b80: 73 29 09 3b 20 44 6f 6e 27 74 20 63 6f 70 79 20 s).; Don't copy 8b90: 61 6e 79 20 6c 69 73 74 73 0a 20 20 20 20 20 20 any lists. 8ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 (( 8bb0: 6e 75 6c 6c 3f 20 61 6e 73 29 20 6c 69 73 29 20 null? ans) lis) 8bc0: 09 3b 20 69 66 20 77 65 20 64 6f 6e 27 74 20 68 .; if we don't h 8bd0: 61 76 65 20 74 6f 2e 0a 20 20 20 20 20 20 20 20 ave to.. 8be0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 ((eq 8bf0: 3f 20 6c 69 73 20 61 6e 73 29 20 61 6e 73 29 0a ? lis ans) ans). 8c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8c10: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else. 8c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 8c30: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 65 6c fold (lambda (el 8c40: 74 20 61 6e 73 29 20 28 69 66 20 28 61 6e 79 20 t ans) (if (any 8c50: 28 6c 61 6d 62 64 61 20 28 78 29 20 28 3d 20 78 (lambda (x) (= x 8c60: 20 65 6c 74 29 29 20 61 6e 73 29 0a 20 20 20 20 elt)) ans). 8c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 6e 73 ans 8ca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8cd0: 20 20 28 63 6f 6e 73 20 65 6c 74 20 61 6e 73 29 (cons elt ans) 8ce0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 6e an 8d00: 73 20 6c 69 73 29 29 29 29 0a 20 20 20 20 20 20 s lis)))). 8d10: 20 20 20 20 20 20 27 28 29 20 6c 69 73 74 73 29 '() lists) 8d20: 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 73 ).. (define (ls 8d30: 65 74 2d 75 6e 69 6f 6e 21 20 3d 20 2e 20 6c 69 et-union! = . li 8d40: 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d sts). (check- 8d50: 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 3d arg procedure? = 8d60: 20 6c 73 65 74 2d 75 6e 69 6f 6e 21 29 0a 20 20 lset-union!). 8d70: 20 20 28 72 65 64 75 63 65 20 28 6c 61 6d 62 64 (reduce (lambd 8d80: 61 20 28 6c 69 73 20 61 6e 73 29 09 09 3b 20 53 a (lis ans)..; S 8d90: 70 6c 69 63 65 20 6e 65 77 20 65 6c 74 73 20 6f plice new elts o 8da0: 66 20 4c 49 53 20 6f 6e 74 6f 20 74 68 65 20 66 f LIS onto the f 8db0: 72 6f 6e 74 20 6f 66 20 41 4e 53 2e 0a 20 20 20 ront of ANS.. 8dc0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond 8dd0: 20 28 28 6e 75 6c 6c 3f 20 6c 69 73 29 20 61 6e ((null? lis) an 8de0: 73 29 09 3b 20 44 6f 6e 27 74 20 63 6f 70 79 20 s).; Don't copy 8df0: 61 6e 79 20 6c 69 73 74 73 0a 20 20 20 20 20 20 any lists. 8e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 (( 8e10: 6e 75 6c 6c 3f 20 61 6e 73 29 20 6c 69 73 29 20 null? ans) lis) 8e20: 09 3b 20 69 66 20 77 65 20 64 6f 6e 27 74 20 68 .; if we don't h 8e30: 61 76 65 20 74 6f 2e 0a 20 20 20 20 20 20 20 20 ave to.. 8e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 ((eq 8e50: 3f 20 6c 69 73 20 61 6e 73 29 20 61 6e 73 29 0a ? lis ans) ans). 8e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8e70: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else. 8e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 8e90: 70 61 69 72 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 pair-fold (lambd 8ea0: 61 20 28 70 61 69 72 20 61 6e 73 29 0a 20 20 20 a (pair ans). 8eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 8ed0: 6c 65 74 20 28 28 65 6c 74 20 28 63 61 72 20 70 let ((elt (car p 8ee0: 61 69 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 air))). 8ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8f00: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 8f10: 61 6e 79 20 28 6c 61 6d 62 64 61 20 28 78 29 20 any (lambda (x) 8f20: 28 3d 20 78 20 65 6c 74 29 29 20 61 6e 73 29 0a (= x elt)) ans). 8f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8f50: 20 20 20 20 20 20 20 20 61 6e 73 0a 20 20 20 20 ans. 8f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8f80: 20 20 20 20 28 62 65 67 69 6e 20 28 73 65 74 2d (begin (set- 8f90: 63 64 72 21 20 70 61 69 72 20 61 6e 73 29 20 70 cdr! pair ans) p 8fa0: 61 69 72 29 29 29 29 0a 20 20 20 20 20 20 20 20 air)))). 8fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 8fc0: 20 20 20 20 20 20 20 20 61 6e 73 20 6c 69 73 29 ans lis) 8fd0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 8fe0: 27 28 29 20 6c 69 73 74 73 29 29 0a 0a 0a 20 20 '() lists))... 8ff0: 28 64 65 66 69 6e 65 20 28 6c 73 65 74 2d 69 6e (define (lset-in 9000: 74 65 72 73 65 63 74 69 6f 6e 20 3d 20 6c 69 73 tersection = lis 9010: 31 20 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 1 . lists). ( 9020: 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 check-arg proced 9030: 75 72 65 3f 20 3d 20 6c 73 65 74 2d 69 6e 74 65 ure? = lset-inte 9040: 72 73 65 63 74 69 6f 6e 29 0a 20 20 20 20 28 6c rsection). (l 9050: 65 74 20 28 28 6c 69 73 74 73 20 28 64 65 6c 65 et ((lists (dele 9060: 74 65 20 6c 69 73 31 20 6c 69 73 74 73 20 65 71 te lis1 lists eq 9070: 3f 29 29 29 20 3b 20 54 68 72 6f 77 20 6f 75 74 ?))) ; Throw out 9080: 20 61 6e 79 20 4c 49 53 31 20 76 61 6c 73 2e 0a any LIS1 vals.. 9090: 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 61 6e (cond ((an 90a0: 79 20 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 y null-list? lis 90b0: 74 73 29 20 27 28 29 29 09 09 3b 20 53 68 6f 72 ts) '())..; Shor 90c0: 74 20 63 75 74 0a 20 20 20 20 20 20 20 20 20 20 t cut. 90d0: 20 20 28 28 6e 75 6c 6c 3f 20 6c 69 73 74 73 29 ((null? lists) 90e0: 20 20 20 20 20 20 20 20 20 20 6c 69 73 31 29 09 lis1). 90f0: 09 3b 20 53 68 6f 72 74 20 63 75 74 0a 20 20 20 .; Short cut. 9100: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 (else ( 9110: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda ( 9120: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x). 9130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 9140: 65 76 65 72 79 20 28 6c 61 6d 62 64 61 20 28 6c every (lambda (l 9150: 69 73 29 20 28 6d 65 6d 62 65 72 20 78 20 6c 69 is) (member x li 9160: 73 20 3d 29 29 20 6c 69 73 74 73 29 29 0a 20 20 s =)) lists)). 9170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9180: 20 20 20 20 20 20 20 20 6c 69 73 31 29 29 29 29 lis1)))) 9190: 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 73 ).. (define (ls 91a0: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 et-intersection! 91b0: 20 3d 20 6c 69 73 31 20 2e 20 6c 69 73 74 73 29 = lis1 . lists) 91c0: 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 . (check-arg 91d0: 70 72 6f 63 65 64 75 72 65 3f 20 3d 20 6c 73 65 procedure? = lse 91e0: 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 29 t-intersection!) 91f0: 0a 20 20 20 20 28 6c 65 74 20 28 28 6c 69 73 74 . (let ((list 9200: 73 20 28 64 65 6c 65 74 65 20 6c 69 73 31 20 6c s (delete lis1 l 9210: 69 73 74 73 20 65 71 3f 29 29 29 20 3b 20 54 68 ists eq?))) ; Th 9220: 72 6f 77 20 6f 75 74 20 61 6e 79 20 4c 49 53 31 row out any LIS1 9230: 20 76 61 6c 73 2e 0a 20 20 20 20 20 20 28 63 6f vals.. (co 9240: 6e 64 20 28 28 61 6e 79 20 6e 75 6c 6c 2d 6c 69 nd ((any null-li 9250: 73 74 3f 20 6c 69 73 74 73 29 20 27 28 29 29 09 st? lists) '()). 9260: 09 3b 20 53 68 6f 72 74 20 63 75 74 0a 20 20 20 .; Short cut. 9270: 20 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f ((null? 9280: 20 6c 69 73 74 73 29 20 20 20 20 20 20 20 20 20 lists) 9290: 20 6c 69 73 31 29 09 09 3b 20 53 68 6f 72 74 20 lis1)..; Short 92a0: 63 75 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 cut. 92b0: 28 65 6c 73 65 20 28 66 69 6c 74 65 72 21 20 28 (else (filter! ( 92c0: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x). 92d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 92e0: 20 20 20 20 20 20 20 20 28 65 76 65 72 79 20 28 (every ( 92f0: 6c 61 6d 62 64 61 20 28 6c 69 73 29 20 28 6d 65 lambda (lis) (me 9300: 6d 62 65 72 20 78 20 6c 69 73 20 3d 29 29 20 6c mber x lis =)) l 9310: 69 73 74 73 29 29 0a 20 20 20 20 20 20 20 20 20 ists)). 9320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9330: 20 20 6c 69 73 31 29 29 29 29 29 0a 0a 0a 20 20 lis1)))))... 9340: 28 64 65 66 69 6e 65 20 28 6c 73 65 74 2d 64 69 (define (lset-di 9350: 66 66 65 72 65 6e 63 65 20 3d 20 6c 69 73 31 20 fference = lis1 9360: 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 63 68 . lists). (ch 9370: 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 eck-arg procedur 9380: 65 3f 20 3d 20 6c 73 65 74 2d 64 69 66 66 65 72 e? = lset-differ 9390: 65 6e 63 65 29 0a 20 20 20 20 28 6c 65 74 20 28 ence). (let ( 93a0: 28 6c 69 73 74 73 20 28 66 69 6c 74 65 72 20 70 (lists (filter p 93b0: 61 69 72 3f 20 6c 69 73 74 73 29 29 29 09 3b 20 air? lists))).; 93c0: 54 68 72 6f 77 20 6f 75 74 20 65 6d 70 74 79 20 Throw out empty 93d0: 6c 69 73 74 73 2e 0a 20 20 20 20 20 20 28 63 6f lists.. (co 93e0: 6e 64 20 28 28 6e 75 6c 6c 3f 20 6c 69 73 74 73 nd ((null? lists 93f0: 29 20 20 20 20 20 6c 69 73 31 29 09 3b 20 53 68 ) lis1).; Sh 9400: 6f 72 74 20 63 75 74 0a 20 20 20 20 20 20 20 20 ort cut. 9410: 20 20 20 20 28 28 6d 65 6d 71 20 6c 69 73 31 20 ((memq lis1 9420: 6c 69 73 74 73 29 20 27 28 29 29 09 3b 20 53 68 lists) '()).; Sh 9430: 6f 72 74 20 63 75 74 0a 20 20 20 20 20 20 20 20 ort cut. 9440: 20 20 20 20 28 65 6c 73 65 20 28 66 69 6c 74 65 (else (filte 9450: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 r (lambda (x). 9460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9470: 20 20 20 20 20 20 20 20 20 20 28 65 76 65 72 79 (every 9480: 20 28 6c 61 6d 62 64 61 20 28 6c 69 73 29 20 28 (lambda (lis) ( 9490: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 78 20 6c 69 not (member x li 94a0: 73 20 3d 29 29 29 0a 20 20 20 20 20 20 20 20 20 s =))). 94b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 94c0: 20 20 20 20 20 20 20 20 20 20 6c 69 73 74 73 29 lists) 94d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 94e0: 20 20 20 20 20 20 20 20 20 20 20 20 6c 69 73 31 lis1 94f0: 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 ))))).. (define 9500: 20 28 6c 73 65 74 2d 64 69 66 66 65 72 65 6e 63 (lset-differenc 9510: 65 21 20 3d 20 6c 69 73 31 20 2e 20 6c 69 73 74 e! = lis1 . list 9520: 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 72 s). (check-ar 9530: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 3d 20 6c g procedure? = l 9540: 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 21 29 set-difference!) 9550: 0a 20 20 20 20 28 6c 65 74 20 28 28 6c 69 73 74 . (let ((list 9560: 73 20 28 66 69 6c 74 65 72 20 70 61 69 72 3f 20 s (filter pair? 9570: 6c 69 73 74 73 29 29 29 09 3b 20 54 68 72 6f 77 lists))).; Throw 9580: 20 6f 75 74 20 65 6d 70 74 79 20 6c 69 73 74 73 out empty lists 9590: 2e 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 .. (cond (( 95a0: 6e 75 6c 6c 3f 20 6c 69 73 74 73 29 20 20 20 20 null? lists) 95b0: 20 6c 69 73 31 29 09 3b 20 53 68 6f 72 74 20 63 lis1).; Short c 95c0: 75 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ut. ( 95d0: 28 6d 65 6d 71 20 6c 69 73 31 20 6c 69 73 74 73 (memq lis1 lists 95e0: 29 20 27 28 29 29 09 3b 20 53 68 6f 72 74 20 63 ) '()).; Short c 95f0: 75 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ut. ( 9600: 65 6c 73 65 20 28 66 69 6c 74 65 72 21 20 28 6c else (filter! (l 9610: 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 ambda (x). 9620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9630: 20 20 20 20 20 20 20 28 65 76 65 72 79 20 28 6c (every (l 9640: 61 6d 62 64 61 20 28 6c 69 73 29 20 28 6e 6f 74 ambda (lis) (not 9650: 20 28 6d 65 6d 62 65 72 20 78 20 6c 69 73 20 3d (member x lis = 9660: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 9670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9680: 20 20 20 20 20 20 20 20 6c 69 73 74 73 29 29 0a lists)). 9690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 96a0: 20 20 20 20 20 20 20 20 20 20 20 6c 69 73 31 29 lis1) 96b0: 29 29 29 29 0a 0a 0a 20 20 28 64 65 66 69 6e 65 ))))... (define 96c0: 20 28 6c 73 65 74 2d 78 6f 72 20 3d 20 2e 20 6c (lset-xor = . l 96d0: 69 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b ists). (check 96e0: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure? 96f0: 3d 20 6c 73 65 74 2d 78 6f 72 29 0a 20 20 20 20 = lset-xor). 9700: 28 72 65 64 75 63 65 20 28 6c 61 6d 62 64 61 20 (reduce (lambda 9710: 28 62 20 61 29 09 09 09 3b 20 43 6f 6d 70 75 74 (b a)...; Comput 9720: 65 20 41 20 78 6f 72 20 42 3a 0a 20 20 20 20 20 e A xor B:. 9730: 20 20 20 20 20 20 20 20 20 3b 3b 20 4e 6f 74 65 ;; Note 9740: 20 74 68 61 74 20 74 68 69 73 20 63 6f 64 65 20 that this code 9750: 72 65 6c 69 65 73 20 6f 6e 20 74 68 65 20 63 6f relies on the co 9760: 6e 73 74 61 6e 74 2d 74 69 6d 65 0a 20 20 20 20 nstant-time. 9770: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 73 68 6f ;; sho 9780: 72 74 2d 63 75 74 73 20 70 72 6f 76 69 64 65 64 rt-cuts provided 9790: 20 62 79 20 4c 53 45 54 2d 44 49 46 46 2b 49 4e by LSET-DIFF+IN 97a0: 54 45 52 53 45 43 54 49 4f 4e 2c 0a 20 20 20 20 TERSECTION,. 97b0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 4c 53 45 ;; LSE 97c0: 54 2d 44 49 46 46 45 52 45 4e 43 45 20 26 20 41 T-DIFFERENCE & A 97d0: 50 50 45 4e 44 20 74 6f 20 70 72 6f 76 69 64 65 PPEND to provide 97e0: 20 63 6f 6e 73 74 61 6e 74 2d 74 69 6d 65 20 73 constant-time s 97f0: 68 6f 72 74 0a 20 20 20 20 20 20 20 20 20 20 20 hort. 9800: 20 20 20 3b 3b 20 63 75 74 73 20 66 6f 72 20 74 ;; cuts for t 9810: 68 65 20 63 61 73 65 73 20 41 20 3d 20 28 29 2c he cases A = (), 9820: 20 42 20 3d 20 28 29 2c 20 61 6e 64 20 41 20 65 B = (), and A e 9830: 71 3f 20 42 2e 20 49 74 20 74 61 6b 65 73 0a 20 q? B. It takes. 9840: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;; 9850: 61 20 63 61 72 65 66 75 6c 20 63 61 73 65 20 61 a careful case a 9860: 6e 61 6c 79 73 69 73 20 74 6f 20 73 65 65 20 69 nalysis to see i 9870: 74 2c 20 62 75 74 20 69 74 27 73 20 63 61 72 65 t, but it's care 9880: 66 75 6c 6c 79 0a 20 20 20 20 20 20 20 20 20 20 fully. 9890: 20 20 20 20 3b 3b 20 62 75 69 6c 74 20 69 6e 2e ;; built in. 98a0: 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .. 98b0: 3b 3b 20 43 6f 6d 70 75 74 65 20 61 2d 62 20 61 ;; Compute a-b a 98c0: 6e 64 20 61 5e 62 2c 20 74 68 65 6e 20 63 6f 6d nd a^b, then com 98d0: 70 75 74 65 20 62 2d 28 61 5e 62 29 20 61 6e 64 pute b-(a^b) and 98e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b . ; 98f0: 3b 20 63 6f 6e 73 20 69 74 20 6f 6e 74 6f 20 74 ; cons it onto t 9900: 68 65 20 66 72 6f 6e 74 20 6f 66 20 61 2d 62 2e he front of a-b. 9910: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . ( 9920: 72 65 63 65 69 76 65 20 28 61 2d 62 20 61 2d 69 receive (a-b a-i 9930: 6e 74 2d 62 29 20 20 20 28 6c 73 65 74 2d 64 69 nt-b) (lset-di 9940: 66 66 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 ff+intersection 9950: 3d 20 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 = a b). 9960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c 9970: 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 61 2d 62 29 ond ((null? a-b) 9980: 20 20 20 20 20 28 6c 73 65 74 2d 64 69 66 66 65 (lset-diffe 9990: 72 65 6e 63 65 20 3d 20 62 20 61 29 29 0a 20 20 rence = b a)). 99a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 99b0: 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 6c ((nul 99c0: 6c 3f 20 61 2d 69 6e 74 2d 62 29 20 28 61 70 70 l? a-int-b) (app 99d0: 65 6e 64 20 62 20 61 29 29 0a 20 20 20 20 20 20 end b a)). 99e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 99f0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 66 6f (else (fo 9a00: 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 62 20 61 ld (lambda (xb a 9a10: 6e 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ns). 9a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 9a40: 69 66 20 28 6d 65 6d 62 65 72 20 78 62 20 61 2d if (member xb a- 9a50: 69 6e 74 2d 62 20 3d 29 20 61 6e 73 20 28 63 6f int-b =) ans (co 9a60: 6e 73 20 78 62 20 61 6e 73 29 29 29 0a 20 20 20 ns xb ans))). 9a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9a90: 20 20 20 20 20 20 61 2d 62 0a 20 20 20 20 20 20 a-b. 9aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9ac0: 20 20 20 62 29 29 29 29 29 0a 20 20 20 20 20 20 b))))). 9ad0: 20 20 20 20 20 20 27 28 29 20 6c 69 73 74 73 29 '() lists) 9ae0: 29 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c )... (define (l 9af0: 73 65 74 2d 78 6f 72 21 20 3d 20 2e 20 6c 69 73 set-xor! = . lis 9b00: 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d 61 ts). (check-a 9b10: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 3d 20 rg procedure? = 9b20: 6c 73 65 74 2d 78 6f 72 21 29 0a 20 20 20 20 28 lset-xor!). ( 9b30: 72 65 64 75 63 65 20 28 6c 61 6d 62 64 61 20 28 reduce (lambda ( 9b40: 62 20 61 29 09 09 09 3b 20 43 6f 6d 70 75 74 65 b a)...; Compute 9b50: 20 41 20 78 6f 72 20 42 3a 0a 20 20 20 20 20 20 A xor B:. 9b60: 20 20 20 20 20 20 20 20 3b 3b 20 4e 6f 74 65 20 ;; Note 9b70: 74 68 61 74 20 74 68 69 73 20 63 6f 64 65 20 72 that this code r 9b80: 65 6c 69 65 73 20 6f 6e 20 74 68 65 20 63 6f 6e elies on the con 9b90: 73 74 61 6e 74 2d 74 69 6d 65 0a 20 20 20 20 20 stant-time. 9ba0: 20 20 20 20 20 20 20 20 20 3b 3b 20 73 68 6f 72 ;; shor 9bb0: 74 2d 63 75 74 73 20 70 72 6f 76 69 64 65 64 20 t-cuts provided 9bc0: 62 79 20 4c 53 45 54 2d 44 49 46 46 2b 49 4e 54 by LSET-DIFF+INT 9bd0: 45 52 53 45 43 54 49 4f 4e 2c 0a 20 20 20 20 20 ERSECTION,. 9be0: 20 20 20 20 20 20 20 20 20 3b 3b 20 4c 53 45 54 ;; LSET 9bf0: 2d 44 49 46 46 45 52 45 4e 43 45 20 26 20 41 50 -DIFFERENCE & AP 9c00: 50 45 4e 44 20 74 6f 20 70 72 6f 76 69 64 65 20 PEND to provide 9c10: 63 6f 6e 73 74 61 6e 74 2d 74 69 6d 65 20 73 68 constant-time sh 9c20: 6f 72 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ort. 9c30: 20 20 3b 3b 20 63 75 74 73 20 66 6f 72 20 74 68 ;; cuts for th 9c40: 65 20 63 61 73 65 73 20 41 20 3d 20 28 29 2c 20 e cases A = (), 9c50: 42 20 3d 20 28 29 2c 20 61 6e 64 20 41 20 65 71 B = (), and A eq 9c60: 3f 20 42 2e 20 49 74 20 74 61 6b 65 73 0a 20 20 ? B. It takes. 9c70: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 61 ;; a 9c80: 20 63 61 72 65 66 75 6c 20 63 61 73 65 20 61 6e careful case an 9c90: 61 6c 79 73 69 73 20 74 6f 20 73 65 65 20 69 74 alysis to see it 9ca0: 2c 20 62 75 74 20 69 74 27 73 20 63 61 72 65 66 , but it's caref 9cb0: 75 6c 6c 79 0a 20 20 20 20 20 20 20 20 20 20 20 ully. 9cc0: 20 20 20 3b 3b 20 62 75 69 6c 74 20 69 6e 2e 0a ;; built in.. 9cd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b . ; 9ce0: 3b 20 43 6f 6d 70 75 74 65 20 61 2d 62 20 61 6e ; Compute a-b an 9cf0: 64 20 61 5e 62 2c 20 74 68 65 6e 20 63 6f 6d 70 d a^b, then comp 9d00: 75 74 65 20 62 2d 28 61 5e 62 29 20 61 6e 64 0a ute b-(a^b) and. 9d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;; 9d20: 20 63 6f 6e 73 20 69 74 20 6f 6e 74 6f 20 74 68 cons it onto th 9d30: 65 20 66 72 6f 6e 74 20 6f 66 20 61 2d 62 2e 0a e front of a-b.. 9d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r 9d50: 65 63 65 69 76 65 20 28 61 2d 62 20 61 2d 69 6e eceive (a-b a-in 9d60: 74 2d 62 29 20 20 20 28 6c 73 65 74 2d 64 69 66 t-b) (lset-dif 9d70: 66 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 f+intersection! 9d80: 3d 20 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 = a b). 9d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c 9da0: 6f 6e 64 20 28 28 6e 75 6c 6c 3f 20 61 2d 62 29 ond ((null? a-b) 9db0: 20 20 20 20 20 28 6c 73 65 74 2d 64 69 66 66 65 (lset-diffe 9dc0: 72 65 6e 63 65 21 20 3d 20 62 20 61 29 29 0a 20 rence! = b a)). 9dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9de0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 ((nu 9df0: 6c 6c 3f 20 61 2d 69 6e 74 2d 62 29 20 28 61 70 ll? a-int-b) (ap 9e00: 70 65 6e 64 21 20 62 20 61 29 29 0a 20 20 20 20 pend! b a)). 9e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9e20: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 (else ( 9e30: 70 61 69 72 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 pair-fold (lambd 9e40: 61 20 28 62 2d 70 61 69 72 20 61 6e 73 29 0a 20 a (b-pair ans). 9e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 9e80: 69 66 20 28 6d 65 6d 62 65 72 20 28 63 61 72 20 if (member (car 9e90: 62 2d 70 61 69 72 29 20 61 2d 69 6e 74 2d 62 20 b-pair) a-int-b 9ea0: 3d 29 20 61 6e 73 0a 20 20 20 20 20 20 20 20 20 =) ans. 9eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9ed0: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi 9ee0: 6e 20 28 73 65 74 2d 63 64 72 21 20 62 2d 70 61 n (set-cdr! b-pa 9ef0: 69 72 20 61 6e 73 29 20 62 2d 70 61 69 72 29 29 ir ans) b-pair)) 9f00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 9f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9f30: 61 2d 62 0a 20 20 20 20 20 20 20 20 20 20 20 20 a-b. 9f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 9f60: 20 20 62 29 29 29 29 29 0a 20 20 20 20 20 20 20 b))))). 9f70: 20 20 20 20 20 27 28 29 20 6c 69 73 74 73 29 29 '() lists)) 9f80: 0a 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 6c 73 ... (define (ls 9f90: 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 73 65 63 et-diff+intersec 9fa0: 74 69 6f 6e 20 3d 20 6c 69 73 31 20 2e 20 6c 69 tion = lis1 . li 9fb0: 73 74 73 29 0a 20 20 20 20 28 63 68 65 63 6b 2d sts). (check- 9fc0: 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 3d arg procedure? = 9fd0: 20 6c 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 lset-diff+inter 9fe0: 73 65 63 74 69 6f 6e 29 0a 20 20 20 20 28 63 6f section). (co 9ff0: 6e 64 20 28 28 65 76 65 72 79 20 6e 75 6c 6c 2d nd ((every null- a000: 6c 69 73 74 3f 20 6c 69 73 74 73 29 20 28 76 61 list? lists) (va a010: 6c 75 65 73 20 6c 69 73 31 20 27 28 29 29 29 09 lues lis1 '())). a020: 3b 20 53 68 6f 72 74 20 63 75 74 0a 20 20 20 20 ; Short cut. a030: 20 20 20 20 20 20 28 28 6d 65 6d 71 20 6c 69 73 ((memq lis a040: 31 20 6c 69 73 74 73 29 20 20 20 20 20 20 20 20 1 lists) a050: 28 76 61 6c 75 65 73 20 27 28 29 20 6c 69 73 31 (values '() lis1 a060: 29 29 09 3b 20 53 68 6f 72 74 20 63 75 74 0a 20 )).; Short cut. a070: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 (else ( a080: 70 61 72 74 69 74 69 6f 6e 20 28 6c 61 6d 62 64 partition (lambd a090: 61 20 28 65 6c 74 29 0a 20 20 20 20 20 20 20 20 a (elt). a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a0b0: 20 20 20 20 20 28 6e 6f 74 20 28 61 6e 79 20 28 (not (any ( a0c0: 6c 61 6d 62 64 61 20 28 6c 69 73 29 20 28 6d 65 lambda (lis) (me a0d0: 6d 62 65 72 20 65 6c 74 20 6c 69 73 20 3d 29 29 mber elt lis =)) a0e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . a0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a100: 20 20 20 20 20 20 20 20 6c 69 73 74 73 29 29 29 lists))) a110: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . a120: 20 20 20 20 20 20 20 20 20 20 20 20 6c 69 73 31 lis1 a130: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define a140: 28 6c 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 (lset-diff+inter a150: 73 65 63 74 69 6f 6e 21 20 3d 20 6c 69 73 31 20 section! = lis1 a160: 2e 20 6c 69 73 74 73 29 0a 20 20 20 20 28 63 68 . lists). (ch a170: 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 eck-arg procedur a180: 65 3f 20 3d 20 6c 73 65 74 2d 64 69 66 66 2b 69 e? = lset-diff+i a190: 6e 74 65 72 73 65 63 74 69 6f 6e 21 29 0a 20 20 ntersection!). a1a0: 20 20 28 63 6f 6e 64 20 28 28 65 76 65 72 79 20 (cond ((every a1b0: 6e 75 6c 6c 2d 6c 69 73 74 3f 20 6c 69 73 74 73 null-list? lists a1c0: 29 20 28 76 61 6c 75 65 73 20 6c 69 73 31 20 27 ) (values lis1 ' a1d0: 28 29 29 29 09 3b 20 53 68 6f 72 74 20 63 75 74 ())).; Short cut a1e0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 6d 65 6d . ((mem a1f0: 71 20 6c 69 73 31 20 6c 69 73 74 73 29 20 20 20 q lis1 lists) a200: 20 20 20 20 20 28 76 61 6c 75 65 73 20 27 28 29 (values '() a210: 20 6c 69 73 31 29 29 09 3b 20 53 68 6f 72 74 20 lis1)).; Short a220: 63 75 74 0a 20 20 20 20 20 20 20 20 20 20 28 65 cut. (e a230: 6c 73 65 20 28 70 61 72 74 69 74 69 6f 6e 21 20 lse (partition! a240: 28 6c 61 6d 62 64 61 20 28 65 6c 74 29 0a 20 20 (lambda (elt). a250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a260: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 (not a270: 20 28 61 6e 79 20 28 6c 61 6d 62 64 61 20 28 6c (any (lambda (l a280: 69 73 29 20 28 6d 65 6d 62 65 72 20 65 6c 74 20 is) (member elt a290: 6c 69 73 20 3d 29 29 0a 20 20 20 20 20 20 20 20 lis =)). a2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a2b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a2c0: 6c 69 73 74 73 29 29 29 0a 20 20 20 20 20 20 20 lists))). a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 a2e0: 20 20 20 20 20 6c 69 73 31 29 29 29 29 0a 20 20 lis1)))). a2f0: 3b 3b 20 65 6e 64 20 6f 66 20 6c 69 62 72 61 72 ;; end of librar a300: 79 0a 20 20 29 20 0a y. ) .