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