@@ -0,0 +1,1594 @@
1+;; DO NOT EDIT THIS FILE!!
2+;; This inlined chez-srfi library code is autogenerated using command:
3+;; $ ./install.chezscheme.sps ../vendor/
4+;; Source origin: https://github.com/arcfide/chez-srfi
5+;; Please refer to project site for full credits and original code.
6+;;;;;; File header: %3a1/lists.sls
7+#!r6rs
8+;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named
9+;; LICENSE from the original collection this file is distributed with.
10+;;;;;; File header: %3a1/srfi-1-reference.scm
11+;;; SRFI-1 list-processing library -*- Scheme -*-
12+;;; Reference implementation
13+;;;
14+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
15+;;; this code as long as you do not remove this copyright notice or
16+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
17+;;; -Olin
18+(library (purs runtime srfi :1 lists)
19+ (export xcons make-list list-tabulate list-copy proper-list?
20+ circular-list? dotted-list? not-pair? null-list? list=
21+ circular-list length+ iota first second third fourth fifth
22+ sixth seventh eighth ninth tenth car+cdr take drop
23+ take-right drop-right take! drop-right! split-at split-at!
24+ last last-pair zip unzip1 unzip2 unzip3 unzip4 unzip5 count
25+ append! append-reverse append-reverse! concatenate
26+ concatenate! unfold fold pair-fold reduce unfold-right
27+ pair-fold-right reduce-right append-map append-map! map!
28+ pair-for-each filter-map map-in-order filter! partition!
29+ remove! find-tail any every list-index take-while drop-while
30+ take-while! span break span! break! delete delete!
31+ alist-cons alist-copy delete-duplicates delete-duplicates!
32+ alist-delete alist-delete! reverse! lset<= lset= lset-adjoin
33+ lset-union lset-intersection lset-difference lset-xor
34+ lset-diff+intersection lset-union! lset-intersection!
35+ lset-difference! lset-xor! lset-diff+intersection! append
36+ assq assv caaaar caaadr caaar caadar caaddr caadr caar
37+ cadaar cadadr cadar caddar cadddr caddr cadr car cdaaar
38+ cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar
39+ cdddar cddddr cdddr cddr cdr cons cons* length list list-ref
40+ memq memv null? pair? reverse set-car! set-cdr! assoc filter
41+ find fold-right for-each map member partition remove)
42+ (import
43+ (rename
44+ (except (rnrs) find filter fold-right map partition remove)
45+ (assoc r6rs:assoc)
46+ (for-each r6rs:for-each)
47+ (member r6rs:member))
48+ (rnrs mutable-pairs) (purs runtime srfi :8 receive)
49+ (purs runtime srfi :23 error tricks) (for (purs runtime srfi private vanish) expand)
50+ (purs runtime srfi private check-arg) (purs runtime srfi private include))
51+ (let-syntax ([define (vanish-define define (cons*))])
52+ (SRFI-23-error->R6RS
53+ "(library (purs runtime srfi :1 lists))"
54+ (begin
55+ (define (xcons d a) (cons a d))
56+ (define make-list
57+ (case-lambda
58+ [(len) (make-list len #f)]
59+ [(len elt)
60+ (check-arg index? len make-list)
61+ (do ([i len (fx- i 1)] [ans '() (cons elt ans)])
62+ ((fx<=? i 0) ans))]))
63+ (define (list-tabulate len proc)
64+ (check-arg index? len list-tabulate)
65+ (check-arg procedure? proc list-tabulate)
66+ (do ([i (fx- len 1) (fx- i 1)]
67+ [ans '() (cons (proc i) ans)])
68+ ((fx<? i 0) ans)))
69+ (define cons*
70+ (case-lambda
71+ [(first) first]
72+ [(first second) (cons first second)]
73+ [(first second third . rest)
74+ (cons
75+ first
76+ (cons
77+ second
78+ (let recur ([x third] [rest rest])
79+ (if (pair? rest)
80+ (cons x (recur (car rest) (cdr rest)))
81+ x))))]))
82+ (define (list-copy lis)
83+ (let recur ([lis lis])
84+ (if (pair? lis) (cons (car lis) (recur (cdr lis))) lis)))
85+ (define iota
86+ (case-lambda
87+ [(count) (iota count 0 1)]
88+ [(count start) (iota count start 1)]
89+ [(count start step)
90+ (check-arg index? count iota)
91+ (check-arg number? start iota)
92+ (check-arg number? step iota)
93+ (let loop ([cur start] [n 0])
94+ (if (fx=? n count)
95+ '()
96+ (cons cur (loop (fx+ cur step) (fx+ 1 n)))))]))
97+ (define (circular-list val1 . vals)
98+ (let ([ans (cons val1 vals)])
99+ (set-cdr! (last-pair ans) ans)
100+ ans))
101+ (define (proper-list? x)
102+ (let lp ([x x] [lag x])
103+ (if (pair? x)
104+ (let ([x (cdr x)])
105+ (if (pair? x)
106+ (let ([x (cdr x)] [lag (cdr lag)])
107+ (and (not (eq? x lag)) (lp x lag)))
108+ (null? x)))
109+ (null? x))))
110+ (define (dotted-list? x)
111+ (let lp ([x x] [lag x])
112+ (if (pair? x)
113+ (let ([x (cdr x)])
114+ (if (pair? x)
115+ (let ([x (cdr x)] [lag (cdr lag)])
116+ (and (not (eq? x lag)) (lp x lag)))
117+ (not (null? x))))
118+ (not (null? x)))))
119+ (define (circular-list? x)
120+ (let lp ([x x] [lag x])
121+ (and (pair? x)
122+ (let ([x (cdr x)])
123+ (and (pair? x)
124+ (let ([x (cdr x)] [lag (cdr lag)])
125+ (or (eq? x lag) (lp x lag))))))))
126+ (define (not-pair? x) (not (pair? x)))
127+ (define (null-list? l)
128+ (cond
129+ [(pair? l) #f]
130+ [(null? l) #t]
131+ [else (error "null-list?: argument out of domain" l)]))
132+ (define list=
133+ (case-lambda
134+ [(elt=) #t]
135+ [(elt= list-a) #t]
136+ [(elt= list-a list-b)
137+ (or (eq? list-a list-b)
138+ (let loop ([list-a list-a] [list-b list-b])
139+ (if (null-list? list-a)
140+ (null-list? list-b)
141+ (and (not (null-list? list-b))
142+ (elt= (car list-a) (car list-b))
143+ (loop (cdr list-a) (cdr list-b))))))]
144+ [(elt= list-a list-b list-c . lists)
145+ (and (list= elt= list-a list-b)
146+ (list= elt= list-b list-c)
147+ (or (null? lists)
148+ (let loop ([list-a list-c] [lists lists])
149+ (let ([list-b (car lists)] [others (cdr lists)])
150+ (and (list= elt= list-a list-b)
151+ (or (null? others)
152+ (loop list-b others)))))))]))
153+ (define (length+ x)
154+ (let loop ([x x] [len 0])
155+ (if (null? x)
156+ len
157+ (if (fx>? len 20)
158+ (let lp ([x (cdr x)] [lag x] [len (fx+ len 1)])
159+ (if (pair? x)
160+ (let ([x (cdr x)] [len (fx+ len 1)])
161+ (if (pair? x)
162+ (let ([x (cdr x)]
163+ [lag (cdr lag)]
164+ [len (fx+ len 1)])
165+ (and (not (eq? x lag)) (lp x lag len)))
166+ len))
167+ len))
168+ (loop (cdr x) (fx+ len 1))))))
169+ (define (zip list1 . more-lists)
170+ (apply map list list1 more-lists))
171+ (define first car)
172+ (define second cadr)
173+ (define third caddr)
174+ (define fourth cadddr)
175+ (define (fifth x) (car (cddddr x)))
176+ (define (sixth x) (cadr (cddddr x)))
177+ (define (seventh x) (caddr (cddddr x)))
178+ (define (eighth x) (cadddr (cddddr x)))
179+ (define (ninth x) (car (cddddr (cddddr x))))
180+ (define (tenth x) (cadr (cddddr (cddddr x))))
181+ (define (car+cdr pair) (values (car pair) (cdr pair)))
182+ (define (take lis k)
183+ (check-arg fixnum? k take)
184+ (let recur ([lis lis] [k k])
185+ (if (zero? k)
186+ '()
187+ (cons (car lis) (recur (cdr lis) (- k 1))))))
188+ (define (drop lis k)
189+ (check-arg fixnum? k drop)
190+ (let iter ([lis lis] [k k])
191+ (if (zero? k) lis (iter (cdr lis) (- k 1)))))
192+ (define (take! lis k)
193+ (check-arg fixnum? k take!)
194+ (if (zero? k)
195+ '()
196+ (begin (set-cdr! (drop lis (- k 1)) '()) lis)))
197+ (define (take-right lis k)
198+ (check-arg fixnum? k take-right)
199+ (let lp ([lag lis] [lead (drop lis k)])
200+ (if (pair? lead) (lp (cdr lag) (cdr lead)) lag)))
201+ (define (drop-right lis k)
202+ (check-arg fixnum? k drop-right)
203+ (let recur ([lag lis] [lead (drop lis k)])
204+ (if (pair? lead)
205+ (cons (car lag) (recur (cdr lag) (cdr lead)))
206+ '())))
207+ (define (drop-right! lis k)
208+ (check-arg fixnum? k drop-right!)
209+ (let ([lead (drop lis k)])
210+ (if (pair? lead)
211+ (let lp ([lag lis] [lead (cdr lead)])
212+ (if (pair? lead)
213+ (lp (cdr lag) (cdr lead))
214+ (begin (set-cdr! lag '()) lis)))
215+ '())))
216+ (define (split-at x k)
217+ (check-arg fixnum? k split-at)
218+ (let recur ([lis x] [k k])
219+ (if (zero? k)
220+ (values '() lis)
221+ (receive
222+ (prefix suffix)
223+ (recur (cdr lis) (- k 1))
224+ (values (cons (car lis) prefix) suffix)))))
225+ (define (split-at! x k)
226+ (check-arg fixnum? k split-at!)
227+ (if (zero? k)
228+ (values '() x)
229+ (let* ([prev (drop x (- k 1))] [suffix (cdr prev)])
230+ (set-cdr! prev '())
231+ (values x suffix))))
232+ (define (last lis) (car (last-pair lis)))
233+ (define (last-pair lis)
234+ (check-arg pair? lis last-pair)
235+ (let lp ([lis lis])
236+ (let ([tail (cdr lis)]) (if (pair? tail) (lp tail) lis))))
237+ (define (unzip1 lis) (map car lis))
238+ (define (unzip2 lis)
239+ (let recur ([lis lis])
240+ (if (null-list? lis)
241+ (values lis lis)
242+ (let ([elt (car lis)])
243+ (receive
244+ (a b)
245+ (recur (cdr lis))
246+ (values (cons (car elt) a) (cons (cadr elt) b)))))))
247+ (define (unzip3 lis)
248+ (let recur ([lis lis])
249+ (if (null-list? lis)
250+ (values lis lis lis)
251+ (let ([elt (car lis)])
252+ (receive
253+ (a b c)
254+ (recur (cdr lis))
255+ (values
256+ (cons (car elt) a)
257+ (cons (cadr elt) b)
258+ (cons (caddr elt) c)))))))
259+ (define (unzip4 lis)
260+ (let recur ([lis lis])
261+ (if (null-list? lis)
262+ (values lis lis lis lis)
263+ (let ([elt (car lis)])
264+ (receive
265+ (a b c d)
266+ (recur (cdr lis))
267+ (values
268+ (cons (car elt) a)
269+ (cons (cadr elt) b)
270+ (cons (caddr elt) c)
271+ (cons (cadddr elt) d)))))))
272+ (define (unzip5 lis)
273+ (let recur ([lis lis])
274+ (if (null-list? lis)
275+ (values lis lis lis lis lis)
276+ (let ([elt (car lis)])
277+ (receive
278+ (a b c d e)
279+ (recur (cdr lis))
280+ (values (cons (car elt) a) (cons (cadr elt) b)
281+ (cons (caddr elt) c) (cons (cadddr elt) d)
282+ (cons (car (cddddr elt)) e)))))))
283+ (define append!
284+ (case-lambda
285+ [() '()]
286+ [(lis1) lis1]
287+ [(lis1 lis2)
288+ (cond
289+ [(null? lis2) lis1]
290+ [(null? lis1) lis2]
291+ [else (set-cdr! (last-pair lis1) lis2) lis1])]
292+ [(lis1 lis2 lis3 . lists)
293+ (let ([append-2! (lambda (lis1 lis2)
294+ (set-cdr! (last-pair lis1) lis2)
295+ lis1)]
296+ [lists (delete '() lists)])
297+ (if (null? lists)
298+ (if (null? lis3)
299+ (append! lis1 lis2)
300+ (let* ([lis (if (null? lis2)
301+ lis3
302+ (append-2! lis2 lis3))]
303+ [lis (if (null? lis1)
304+ lis
305+ (append-2! lis1 lis))])
306+ lis))
307+ (let* ([lis (let loop ([lis (car lists)]
308+ [lists (cdr lists)])
309+ (if (null? lists)
310+ lis
311+ (append-2!
312+ lis
313+ (loop (car lists) (cdr lists)))))]
314+ [lis (if (null? lis3) lis (append-2! lis3 lis))]
315+ [lis (if (null? lis2) lis (append-2! lis2 lis))]
316+ [lis (if (null? lis1) lis (append-2! lis1 lis))])
317+ lis)))]))
318+ (define (append-reverse rev-head tail)
319+ (let lp ([rev-head rev-head] [tail tail])
320+ (if (null-list? rev-head)
321+ tail
322+ (lp (cdr rev-head) (cons (car rev-head) tail)))))
323+ (define (append-reverse! rev-head tail)
324+ (let lp ([rev-head rev-head] [tail tail])
325+ (if (null-list? rev-head)
326+ tail
327+ (let ([next-rev (cdr rev-head)])
328+ (set-cdr! rev-head tail)
329+ (lp next-rev rev-head)))))
330+ (define (concatenate lists) (reduce-right append '() lists))
331+ (define (concatenate! lists)
332+ (reduce-right append! '() lists))
333+ (define (%cdrs lists)
334+ (let f ([ls lists])
335+ (if (pair? ls)
336+ (let ([x (car ls)])
337+ (if (null? x) '() (cons (cdr x) (f (cdr ls)))))
338+ '())))
339+ (define (%cars+ lists last-elt)
340+ (let recur ([lists lists])
341+ (if (pair? lists)
342+ (cons (caar lists) (recur (cdr lists)))
343+ (list last-elt))))
344+ (define (%cars+cdrs lists)
345+ (let f ([ls lists])
346+ (if (pair? ls)
347+ (let ([x (car ls)])
348+ (if (null-list? x)
349+ (values '() '())
350+ (receive
351+ (cars cdrs)
352+ (f (cdr ls))
353+ (values (cons (car x) cars) (cons (cdr x) cdrs)))))
354+ (values '() '()))))
355+ (define (%cars+cdrs+ lists cars-final)
356+ (let f ([ls lists])
357+ (if (pair? ls)
358+ (let ([x (car ls)])
359+ (if (null-list? x)
360+ (values '() '())
361+ (receive
362+ (cars cdrs)
363+ (f (cdr ls))
364+ (values (cons (car x) cars) (cons (cdr x) cdrs)))))
365+ (values (list cars-final) '()))))
366+ (define (%cars+cdrs/no-test lists)
367+ (let recur ([lists lists])
368+ (if (pair? lists)
369+ (receive
370+ (list other-lists)
371+ (car+cdr lists)
372+ (receive
373+ (a d)
374+ (car+cdr list)
375+ (receive
376+ (cars cdrs)
377+ (recur other-lists)
378+ (values (cons a cars) (cons d cdrs)))))
379+ (values '() '()))))
380+ (define count
381+ (case-lambda
382+ [(pred list1)
383+ (check-arg procedure? pred count)
384+ (let lp ([lis list1] [i 0])
385+ (if (null-list? lis)
386+ i
387+ (lp (cdr lis) (if (pred (car lis)) (fx+ i 1) i))))]
388+ [(pred list1 . lists)
389+ (check-arg procedure? pred count)
390+ (let lp ([list1 list1] [lists lists] [i 0])
391+ (if (null-list? list1)
392+ i
393+ (receive
394+ (as ds)
395+ (%cars+cdrs lists)
396+ (if (null? as)
397+ i
398+ (lp (cdr list1)
399+ ds
400+ (if (apply pred (car list1) as)
401+ (fx+ i 1)
402+ i))))))]))
403+ (define unfold-right
404+ (case-lambda
405+ [(p f g seed) (unfold-right p f g seed '())]
406+ [(p f g seed tail)
407+ (check-arg procedure? p unfold-right)
408+ (check-arg procedure? f unfold-right)
409+ (check-arg procedure? g unfold-right)
410+ (let lp ([seed seed] [ans tail])
411+ (if (p seed) ans (lp (g seed) (cons (f seed) ans))))]))
412+ (define unfold
413+ (case-lambda
414+ [(p f g seed)
415+ (check-arg procedure? p unfold)
416+ (check-arg procedure? f unfold)
417+ (check-arg procedure? g unfold)
418+ (let recur ([seed seed])
419+ (if (p seed) '() (cons (f seed) (recur (g seed)))))]
420+ [(p f g seed tail-gen)
421+ (check-arg procedure? p unfold)
422+ (check-arg procedure? f unfold)
423+ (check-arg procedure? g unfold)
424+ (let recur ([seed seed])
425+ (if (p seed)
426+ (tail-gen seed)
427+ (cons (f seed) (recur (g seed)))))]))
428+ (define fold
429+ (case-lambda
430+ [(kons knil lis1)
431+ (check-arg procedure? kons fold)
432+ (let lp ([lis lis1] [ans knil])
433+ (if (null-list? lis)
434+ ans
435+ (lp (cdr lis) (kons (car lis) ans))))]
436+ [(kons knil lis1 lis2)
437+ (check-arg procedure? kons fold)
438+ (let lp ([lis1 lis1] [lis2 lis2] [ans knil])
439+ (if (or (null-list? lis1) (null-list? lis2))
440+ ans
441+ (lp (cdr lis1)
442+ (cdr lis2)
443+ (kons (car lis1) (car lis2) ans))))]
444+ [(kons knil . lists)
445+ (check-arg procedure? kons fold)
446+ (let lp ([lists lists] [ans knil])
447+ (receive
448+ (cars+ans cdrs)
449+ (%cars+cdrs+ lists ans)
450+ (if (null? cars+ans)
451+ ans
452+ (lp cdrs (apply kons cars+ans)))))]))
453+ (define fold-right
454+ (case-lambda
455+ [(kons knil lis1)
456+ (check-arg procedure? kons fold-right)
457+ (let recur ([lis lis1])
458+ (if (null-list? lis)
459+ knil
460+ (kons (car lis) (recur (cdr lis)))))]
461+ [(kons knil lis1 lis2)
462+ (check-arg procedure? kons fold-right)
463+ (let recur ([lis1 lis1] [lis2 lis2])
464+ (if (or (null-list? lis1) (null-list? lis2))
465+ knil
466+ (kons
467+ (car lis1)
468+ (car lis2)
469+ (recur (cdr lis1) (cdr lis2)))))]
470+ [(kons knil . lists)
471+ (check-arg procedure? kons fold-right)
472+ (let recur ([lists lists])
473+ (let ([cdrs (%cdrs lists)])
474+ (if (null? cdrs)
475+ knil
476+ (apply kons (%cars+ lists (recur cdrs))))))]))
477+ (define pair-fold-right
478+ (case-lambda
479+ [(f zero lis1)
480+ (check-arg procedure? f pair-fold-right)
481+ (let recur ([lis lis1])
482+ (if (null-list? lis) zero (f lis (recur (cdr lis)))))]
483+ [(f zero lis1 lis2 . lists)
484+ (check-arg procedure? f pair-fold-right)
485+ (let recur ([lis1 lis1] [lis2 lis2] [lists lists])
486+ (if (or (null-list? lis1) (null-list? lis2))
487+ zero
488+ (let ([cdrs (%cdrs lists)])
489+ (if (null? cdrs)
490+ zero
491+ (apply
492+ f
493+ lis1
494+ lis2
495+ (append!
496+ lists
497+ (list
498+ (recur (cdr lis1) (cdr lis2) cdrs))))))))]))
499+ (define pair-fold
500+ (case-lambda
501+ [(f zero lis1)
502+ (check-arg procedure? f pair-fold)
503+ (let lp ([lis lis1] [ans zero])
504+ (if (null? lis)
505+ ans
506+ (let ([tail (cdr lis)]) (lp tail (f lis ans)))))]
507+ [(f zero lis1 lis2 . lists)
508+ (check-arg procedure? f pair-fold)
509+ (let lp ([lis1 lis1] [lis2 lis2] [lists lists] [ans zero])
510+ (if (or (null-list? lis1) (null-list? lis2))
511+ ans
512+ (let ([tails (%cdrs lists)])
513+ (if (null? tails)
514+ ans
515+ (lp (cdr lis1)
516+ (cdr lis2)
517+ tails
518+ (apply
519+ f
520+ lis1
521+ lis2
522+ (append! lists (list ans))))))))]))
523+ (define (reduce f ridentity lis)
524+ (check-arg procedure? f reduce)
525+ (if (null-list? lis)
526+ ridentity
527+ (fold f (car lis) (cdr lis))))
528+ (define (reduce-right f ridentity lis)
529+ (check-arg procedure? f reduce-right)
530+ (if (null-list? lis)
531+ ridentity
532+ (let recur ([head (car lis)] [lis (cdr lis)])
533+ (if (pair? lis)
534+ (f head (recur (car lis) (cdr lis)))
535+ head))))
536+ (define append-map
537+ (case-lambda
538+ [(f lis1) (really-append-map append-map append f lis1)]
539+ [(f lis1 lis2)
540+ (really-append-map append-map append f lis1 lis2)]
541+ [(f lis1 lis2 . lists)
542+ (really-append-map append-map append f lis1 lis2 lists)]))
543+ (define append-map!
544+ (case-lambda
545+ [(f lis1) (really-append-map append-map! append! f lis1)]
546+ [(f lis1 lis2)
547+ (really-append-map append-map! append! f lis1 lis2)]
548+ [(f lis1 lis2 . lists)
549+ (really-append-map append-map! append! f lis1 lis2 lists)]))
550+ (define really-append-map
551+ (case-lambda
552+ [(who appender f lis1)
553+ (check-arg procedure? f who)
554+ (if (null-list? lis1)
555+ '()
556+ (let recur ([elt (car lis1)] [rest (cdr lis1)])
557+ (let ([vals (f elt)])
558+ (if (null-list? rest)
559+ vals
560+ (appender vals (recur (car rest) (cdr rest)))))))]
561+ [(who appender f lis1 lis2)
562+ (check-arg procedure? f who)
563+ (if (or (null-list? lis1) (null-list? lis2))
564+ '()
565+ (let recur ([lis1 lis1] [lis2 lis2])
566+ (let ([vals (f (car lis1) (car lis2))]
567+ [lis1 (cdr lis1)]
568+ [lis2 (cdr lis2)])
569+ (if (or (null-list? lis1) (null-list? lis2))
570+ vals
571+ (appender vals (recur lis1 lis2))))))]
572+ [(who appender f lis1 lis2 lists)
573+ (check-arg procedure? f who)
574+ (if (or (null-list? lis1) (null-list? lis2))
575+ '()
576+ (receive
577+ (cars cdrs)
578+ (%cars+cdrs lists)
579+ (if (null? cars)
580+ '()
581+ (let recur ([lis1 lis1]
582+ [lis2 lis2]
583+ [cars cars]
584+ [cdrs cdrs])
585+ (let ([vals (apply f (car lis1) (car lis2) cars)]
586+ [lis1 (cdr lis1)]
587+ [lis2 (cdr lis2)])
588+ (if (or (null-list? lis1) (null-list? lis2))
589+ vals
590+ (receive
591+ (cars2 cdrs2)
592+ (%cars+cdrs cdrs)
593+ (if (null? cars2)
594+ vals
595+ (appender
596+ vals
597+ (recur
598+ lis1
599+ lis2
600+ cars2
601+ cdrs2))))))))))]))
602+ (define pair-for-each
603+ (case-lambda
604+ [(proc lis1)
605+ (check-arg procedure? proc pair-for-each)
606+ (let lp ([lis lis1])
607+ (if (not (null-list? lis))
608+ (let ([tail (cdr lis)]) (proc lis) (lp tail))))]
609+ [(proc lis1 lis2 . lists)
610+ (check-arg procedure? proc pair-for-each)
611+ (let lp ([lis1 lis1] [lis2 lis2] [lists lists])
612+ (if (and (pair? lis1) (pair? lis2))
613+ (let ([tails (%cdrs lists)])
614+ (if (pair? tails)
615+ (begin
616+ (apply proc lis1 lis2 lists)
617+ (lp (cdr lis1) (cdr lis2) tails))))))]))
618+ (define map!
619+ (case-lambda
620+ [(f lis1)
621+ (check-arg procedure? f map!)
622+ (let lp ([lis1 lis1])
623+ (when (not (null-list? lis1))
624+ (set-car! lis1 (f (car lis1)))
625+ (lp (cdr lis1))))
626+ lis1]
627+ [(f lis1 lis2)
628+ (check-arg procedure? f map!)
629+ (let lp ([lis1 lis1] [lis2 lis2])
630+ (when (not (null-list? lis1))
631+ (set-car! lis1 (f (car lis1) (car lis2)))
632+ (lp (cdr lis1) (cdr lis2))))
633+ lis1]
634+ [(f lis1 lis2 lis3 . lists)
635+ (check-arg procedure? f map!)
636+ (let lp ([lis1 lis1] [lis2 lis2] [lis3 lis3] [lists lists])
637+ (when (not (null-list? lis1))
638+ (receive
639+ (heads tails)
640+ (%cars+cdrs/no-test lists)
641+ (set-car!
642+ lis1
643+ (apply f (car lis1) (car lis2) (car lis3) heads))
644+ (lp (cdr lis1) (cdr lis2) (cdr lis3) tails))))
645+ lis1]))
646+ (define filter-map
647+ (case-lambda
648+ [(f lis1)
649+ (check-arg procedure? f filter-map)
650+ (let recur ([lis lis1])
651+ (if (null-list? lis)
652+ '()
653+ (let ([tail (recur (cdr lis))])
654+ (cond
655+ [(f (car lis)) => (lambda (x) (cons x tail))]
656+ [else tail]))))]
657+ [(f lis1 . lists)
658+ (check-arg procedure? f filter-map)
659+ (let recur ([lis1 lis1] [lists lists])
660+ (if (null-list? lis1)
661+ '()
662+ (receive
663+ (cars cdrs)
664+ (%cars+cdrs lists)
665+ (if (pair? cars)
666+ (cond
667+ [(apply f (car lis1) cars) =>
668+ (lambda (x) (cons x (recur (cdr lis1) cdrs)))]
669+ [else (recur (cdr lis1) cdrs)])
670+ '()))))]))
671+ (define map-in-order
672+ (case-lambda
673+ [(f lis1)
674+ (check-arg procedure? f map-in-order)
675+ (let recur ([lis lis1])
676+ (if (null-list? lis)
677+ lis
678+ (let ([tail (cdr lis)] [x (f (car lis))])
679+ (cons x (recur tail)))))]
680+ [(f lis1 lis2)
681+ (check-arg procedure? f map-in-order)
682+ (let recur ([lis1 lis1] [lis2 lis2])
683+ (if (and (pair? lis1) (pair? lis2))
684+ (let ([x (f (car lis1) (car lis2))])
685+ (cons x (recur (cdr lis1) (cdr lis2))))
686+ '()))]
687+ [(f lis1 lis2 . lists)
688+ (check-arg procedure? f map-in-order)
689+ (let recur ([lis1 lis1] [lis2 lis2] [lists lists])
690+ (receive
691+ (cars cdrs)
692+ (%cars+cdrs lists)
693+ (if (and (pair? lis1) (pair? lis2) (pair? cars))
694+ (let ([x (apply f (car lis1) (car lis2) cars)])
695+ (cons x (recur (cdr lis1) (cdr lis2) cdrs)))
696+ '())))]))
697+ (define map map-in-order)
698+ (define for-each
699+ (case-lambda
700+ [(f lis1) (r6rs:for-each f lis1)]
701+ [(f lis1 lis2)
702+ (check-arg procedure? f for-each)
703+ (let recur ([lis1 lis1] [lis2 lis2])
704+ (unless (or (null-list? lis1) (null-list? lis2))
705+ (f (car lis1) (car lis2))
706+ (recur (cdr lis1) (cdr lis2))))]
707+ [(f lis1 lis2 . lists)
708+ (check-arg procedure? f for-each)
709+ (let recur ([lis1 lis1] [lis2 lis2] [lists lists])
710+ (unless (or (null-list? lis1) (null-list? lis2))
711+ (receive
712+ (cars cdrs)
713+ (%cars+cdrs lists)
714+ (when (pair? cars)
715+ (apply f (car lis1) (car lis2) cars)
716+ (recur (cdr lis1) (cdr lis2) cdrs)))))]))
717+ (define (filter pred lis)
718+ (check-arg procedure? pred filter)
719+ (let recur ([lis lis])
720+ (if (null-list? lis)
721+ lis
722+ (let ([head (car lis)] [tail (cdr lis)])
723+ (if (pred head)
724+ (let ([new-tail (recur tail)])
725+ (if (eq? tail new-tail) lis (cons head new-tail)))
726+ (recur tail))))))
727+ (define (filter! pred lis)
728+ (check-arg procedure? pred filter!)
729+ (let lp ([ans lis])
730+ (cond
731+ [(null-list? ans) ans]
732+ [(not (pred (car ans))) (lp (cdr ans))]
733+ [else
734+ (letrec ([scan-in (lambda (prev lis)
735+ (if (pair? lis)
736+ (if (pred (car lis))
737+ (scan-in lis (cdr lis))
738+ (scan-out prev (cdr lis)))))]
739+ [scan-out (lambda (prev lis)
740+ (let lp ([lis lis])
741+ (if (pair? lis)
742+ (if (pred (car lis))
743+ (begin
744+ (set-cdr! prev lis)
745+ (scan-in lis (cdr lis)))
746+ (lp (cdr lis)))
747+ (set-cdr! prev lis))))])
748+ (scan-in ans (cdr ans))
749+ ans)])))
750+ (define (partition pred lis)
751+ (check-arg procedure? pred partition)
752+ (let recur ([lis lis])
753+ (if (null-list? lis)
754+ (values lis lis)
755+ (let ([elt (car lis)] [tail (cdr lis)])
756+ (receive
757+ (in out)
758+ (recur tail)
759+ (if (pred elt)
760+ (values (if (pair? out) (cons elt in) lis) out)
761+ (values
762+ in
763+ (if (pair? in) (cons elt out) lis))))))))
764+ (define (partition! pred lis)
765+ (check-arg procedure? pred partition!)
766+ (if (null-list? lis)
767+ (values lis lis)
768+ (letrec ([scan-in (lambda (in-prev out-prev lis)
769+ (let lp ([in-prev in-prev] [lis lis])
770+ (if (pair? lis)
771+ (if (pred (car lis))
772+ (lp lis (cdr lis))
773+ (begin
774+ (set-cdr! out-prev lis)
775+ (scan-out
776+ in-prev
777+ lis
778+ (cdr lis))))
779+ (set-cdr! out-prev lis))))]
780+ [scan-out (lambda (in-prev out-prev lis)
781+ (let lp ([out-prev out-prev] [lis lis])
782+ (if (pair? lis)
783+ (if (pred (car lis))
784+ (begin
785+ (set-cdr! in-prev lis)
786+ (scan-in
787+ lis
788+ out-prev
789+ (cdr lis)))
790+ (lp lis (cdr lis)))
791+ (set-cdr! in-prev lis))))])
792+ (if (pred (car lis))
793+ (let lp ([prev-l lis] [l (cdr lis)])
794+ (cond
795+ [(not (pair? l)) (values lis l)]
796+ [(pred (car l)) (lp l (cdr l))]
797+ [else (scan-out prev-l l (cdr l)) (values lis l)]))
798+ (let lp ([prev-l lis] [l (cdr lis)])
799+ (cond
800+ [(not (pair? l)) (values l lis)]
801+ [(pred (car l))
802+ (scan-in l prev-l (cdr l))
803+ (values l lis)]
804+ [else (lp l (cdr l))]))))))
805+ (define (remove pred lis)
806+ (check-arg procedure? pred remove)
807+ (let recur ([lis lis])
808+ (if (null-list? lis)
809+ lis
810+ (let ([head (car lis)] [tail (cdr lis)])
811+ (if (not (pred head))
812+ (let ([new-tail (recur tail)])
813+ (if (eq? tail new-tail) lis (cons head new-tail)))
814+ (recur tail))))))
815+ (define (remove! pred lis)
816+ (check-arg procedure? pred remove!)
817+ (let lp ([ans lis])
818+ (cond
819+ [(null-list? ans) ans]
820+ [(pred (car ans)) (lp (cdr ans))]
821+ [else
822+ (letrec ([scan-in (lambda (prev lis)
823+ (if (pair? lis)
824+ (if (not (pred (car lis)))
825+ (scan-in lis (cdr lis))
826+ (scan-out prev (cdr lis)))))]
827+ [scan-out (lambda (prev lis)
828+ (let lp ([lis lis])
829+ (if (pair? lis)
830+ (if (not (pred (car lis)))
831+ (begin
832+ (set-cdr! prev lis)
833+ (scan-in lis (cdr lis)))
834+ (lp (cdr lis)))
835+ (set-cdr! prev lis))))])
836+ (scan-in ans (cdr ans))
837+ ans)])))
838+ (define delete
839+ (case-lambda
840+ [(x lis) (delete x lis equal?)]
841+ [(x lis elt=)
842+ (let recur ([lis lis])
843+ (if (null-list? lis)
844+ lis
845+ (let ([head (car lis)] [tail (cdr lis)])
846+ (if (not (elt= x head))
847+ (let ([new-tail (recur tail)])
848+ (if (eq? tail new-tail)
849+ lis
850+ (cons head new-tail)))
851+ (recur tail)))))]))
852+ (define delete!
853+ (case-lambda
854+ [(x lis) (delete! x lis equal?)]
855+ [(x lis elt=)
856+ (let lp ([ans lis])
857+ (cond
858+ [(null-list? ans) ans]
859+ [(elt= x (car ans)) (lp (cdr ans))]
860+ [else
861+ (letrec ([scan-in (lambda (prev lis)
862+ (if (pair? lis)
863+ (if (not (elt= x (car lis)))
864+ (scan-in lis (cdr lis))
865+ (scan-out prev (cdr lis)))))]
866+ [scan-out (lambda (prev lis)
867+ (let lp ([lis lis])
868+ (if (pair? lis)
869+ (if (not (elt= x (car lis)))
870+ (begin
871+ (set-cdr! prev lis)
872+ (scan-in lis (cdr lis)))
873+ (lp (cdr lis)))
874+ (set-cdr! prev lis))))])
875+ (scan-in ans (cdr ans))
876+ ans)]))]))
877+ (define member
878+ (case-lambda
879+ [(x lis) (r6rs:member x lis)]
880+ [(x lis elt=)
881+ (let lp ([lis lis])
882+ (and (not (null-list? lis))
883+ (if (elt= x (car lis)) lis (lp (cdr lis)))))]))
884+ (define delete-duplicates
885+ (case-lambda
886+ [(lis) (delete-duplicates lis equal?)]
887+ [(lis elt=)
888+ (check-arg procedure? elt= delete-duplicates)
889+ (let recur ([lis lis])
890+ (if (null-list? lis)
891+ lis
892+ (let* ([x (car lis)]
893+ [tail (cdr lis)]
894+ [new-tail (recur (delete x tail elt=))])
895+ (if (eq? tail new-tail) lis (cons x new-tail)))))]))
896+ (define delete-duplicates!
897+ (case-lambda
898+ [(lis) (delete-duplicates! lis equal?)]
899+ [(lis elt=)
900+ (check-arg procedure? elt= delete-duplicates!)
901+ (let recur ([lis lis])
902+ (if (null-list? lis)
903+ lis
904+ (let* ([x (car lis)]
905+ [tail (cdr lis)]
906+ [new-tail (recur (delete! x tail elt=))])
907+ (if (not (eq? tail new-tail)) (set-cdr! lis new-tail))
908+ lis)))]))
909+ (define assoc
910+ (case-lambda
911+ [(x lis) (r6rs:assoc x lis)]
912+ [(x lis elt=)
913+ (let loop ([lis lis])
914+ (if (pair? lis)
915+ (let ([entry (car lis)])
916+ (if (elt= x (car entry)) entry (loop (cdr lis))))
917+ #f))]))
918+ (define (alist-cons key datum alist)
919+ (cons (cons key datum) alist))
920+ (define (alist-copy alist)
921+ (map (lambda (elt) (cons (car elt) (cdr elt))) alist))
922+ (define alist-delete
923+ (case-lambda
924+ [(key alist)
925+ (remove (lambda (elt) (equal? key (car elt))) alist)]
926+ [(key alist elt=)
927+ (remove (lambda (elt) (elt= key (car elt))) alist)]))
928+ (define alist-delete!
929+ (case-lambda
930+ [(key alist)
931+ (remove! (lambda (elt) (equal? key (car elt))) alist)]
932+ [(key alist elt=)
933+ (remove! (lambda (elt) (elt= key (car elt))) alist)]))
934+ (define (find pred lis)
935+ (check-arg procedure? pred find)
936+ (let loop ([lis lis])
937+ (if (pair? lis)
938+ (let ([head (car lis)])
939+ (if (pred head) head (loop (cdr lis))))
940+ #f)))
941+ (define (find-tail pred lis)
942+ (check-arg procedure? pred find-tail)
943+ (let lp ([lis lis])
944+ (and (not (null-list? lis))
945+ (if (pred (car lis)) lis (lp (cdr lis))))))
946+ (define (take-while pred lis)
947+ (check-arg procedure? pred take-while)
948+ (let recur ([lis lis])
949+ (if (null-list? lis)
950+ '()
951+ (let ([x (car lis)])
952+ (if (pred x) (cons x (recur (cdr lis))) '())))))
953+ (define (drop-while pred lis)
954+ (check-arg procedure? pred drop-while)
955+ (let lp ([lis lis])
956+ (if (null-list? lis)
957+ '()
958+ (if (pred (car lis)) (lp (cdr lis)) lis))))
959+ (define (take-while! pred lis)
960+ (check-arg procedure? pred take-while!)
961+ (if (or (null-list? lis) (not (pred (car lis))))
962+ '()
963+ (begin
964+ (let lp ([prev lis] [rest (cdr lis)])
965+ (if (pair? rest)
966+ (let ([x (car rest)])
967+ (if (pred x)
968+ (lp rest (cdr rest))
969+ (set-cdr! prev '())))))
970+ lis)))
971+ (define (span pred lis)
972+ (check-arg procedure? pred span)
973+ (let recur ([lis lis])
974+ (if (null-list? lis)
975+ (values '() '())
976+ (let ([x (car lis)])
977+ (if (pred x)
978+ (receive
979+ (prefix suffix)
980+ (recur (cdr lis))
981+ (values (cons x prefix) suffix))
982+ (values '() lis))))))
983+ (define (span! pred lis)
984+ (check-arg procedure? pred span!)
985+ (if (or (null-list? lis) (not (pred (car lis))))
986+ (values '() lis)
987+ (let ([suffix (let lp ([prev lis] [rest (cdr lis)])
988+ (if (null-list? rest)
989+ rest
990+ (let ([x (car rest)])
991+ (if (pred x)
992+ (lp rest (cdr rest))
993+ (begin
994+ (set-cdr! prev '())
995+ rest)))))])
996+ (values lis suffix))))
997+ (define (break pred lis)
998+ (check-arg procedure? pred break)
999+ (let recur ([lis lis])
1000+ (if (null-list? lis)
1001+ (values '() '())
1002+ (let ([x (car lis)])
1003+ (if (not (pred x))
1004+ (receive
1005+ (prefix suffix)
1006+ (recur (cdr lis))
1007+ (values (cons x prefix) suffix))
1008+ (values '() lis))))))
1009+ (define (break! pred lis)
1010+ (check-arg procedure? pred break!)
1011+ (if (or (null-list? lis) (pred (car lis)))
1012+ (values '() lis)
1013+ (let ([suffix (let lp ([prev lis] [rest (cdr lis)])
1014+ (if (null-list? rest)
1015+ rest
1016+ (let ([x (car rest)])
1017+ (if (not (pred x))
1018+ (lp rest (cdr rest))
1019+ (begin
1020+ (set-cdr! prev '())
1021+ rest)))))])
1022+ (values lis suffix))))
1023+ (define any
1024+ (case-lambda
1025+ [(pred lis1)
1026+ (check-arg procedure? pred any)
1027+ (and (not (null-list? lis1))
1028+ (let loop ([head (car lis1)] [tail (cdr lis1)])
1029+ (if (null-list? tail)
1030+ (pred head)
1031+ (or (pred head) (loop (car tail) (cdr tail))))))]
1032+ [(pred lis1 lis2)
1033+ (check-arg procedure? pred any)
1034+ (and (not (null-list? lis1))
1035+ (not (null-list? lis2))
1036+ (let loop ([head1 (car lis1)]
1037+ [tail1 (cdr lis1)]
1038+ [head2 (car lis2)]
1039+ [tail2 (cdr lis2)])
1040+ (if (or (null-list? tail1) (null-list? tail2))
1041+ (pred head1 head2)
1042+ (or (pred head1 head2)
1043+ (loop
1044+ (car tail1)
1045+ (cdr tail1)
1046+ (car tail2)
1047+ (cdr tail2))))))]
1048+ [(pred lis1 lis2 . lists)
1049+ (check-arg procedure? pred any)
1050+ (and (not (null-list? lis1))
1051+ (not (null-list? lis2))
1052+ (receive
1053+ (heads tails)
1054+ (%cars+cdrs lists)
1055+ (and (pair? heads)
1056+ (let loop ([head1 (car lis1)]
1057+ [tail1 (cdr lis1)]
1058+ [head2 (car lis2)]
1059+ [tail2 (cdr lis2)]
1060+ [heads heads]
1061+ [tails tails])
1062+ (if (or (null-list? tail1) (null-list? tail2))
1063+ (apply pred head1 head2 heads)
1064+ (receive
1065+ (next-heads next-tails)
1066+ (%cars+cdrs tails)
1067+ (if (null? next-tails)
1068+ (apply pred head1 head2 heads)
1069+ (or (apply pred head1 head2 heads)
1070+ (loop (car tail1) (cdr tail1)
1071+ (car tail2) (cdr tail2)
1072+ next-heads
1073+ next-tails)))))))))]))
1074+ (define every
1075+ (case-lambda
1076+ [(pred lis1)
1077+ (check-arg procedure? pred every)
1078+ (or (null-list? lis1)
1079+ (let loop ([head (car lis1)] [tail (cdr lis1)])
1080+ (if (null-list? tail)
1081+ (pred head)
1082+ (and (pred head) (loop (car tail) (cdr tail))))))]
1083+ [(pred lis1 lis2)
1084+ (check-arg procedure? pred every)
1085+ (or (null-list? lis1)
1086+ (null-list? lis2)
1087+ (let loop ([head1 (car lis1)]
1088+ [tail1 (cdr lis1)]
1089+ [head2 (car lis2)]
1090+ [tail2 (cdr lis2)])
1091+ (if (or (null-list? tail1) (null-list? tail2))
1092+ (pred head1 head2)
1093+ (and (pred head1 head2)
1094+ (loop
1095+ (car tail1)
1096+ (cdr tail1)
1097+ (car tail2)
1098+ (cdr tail2))))))]
1099+ [(pred lis1 lis2 . lists)
1100+ (check-arg procedure? pred every)
1101+ (or (null-list? lis1)
1102+ (null-list? lis2)
1103+ (receive
1104+ (heads tails)
1105+ (%cars+cdrs lists)
1106+ (or (not (pair? heads))
1107+ (let loop ([head1 (car lis1)]
1108+ [tail1 (cdr lis1)]
1109+ [head2 (car lis2)]
1110+ [tail2 (cdr lis2)]
1111+ [heads heads]
1112+ [tails tails])
1113+ (if (or (null-list? tail1) (null-list? tail2))
1114+ (apply pred head1 head2 heads)
1115+ (receive
1116+ (next-heads next-tails)
1117+ (%cars+cdrs tails)
1118+ (if (null? next-tails)
1119+ (apply pred head1 head2 heads)
1120+ (and (apply pred head1 head2 heads)
1121+ (loop (car tail1) (cdr tail1)
1122+ (car tail2) (cdr tail2)
1123+ next-heads next-tails)))))))))]))
1124+ (define list-index
1125+ (case-lambda
1126+ [(pred lis1)
1127+ (check-arg procedure? pred list-index)
1128+ (let loop ([lis lis1] [n 0])
1129+ (and (not (null-list? lis))
1130+ (if (pred (car lis)) n (loop (cdr lis) (fx+ n 1)))))]
1131+ [(pred lis1 lis2)
1132+ (check-arg procedure? pred list-index)
1133+ (let loop ([lis1 lis1] [lis2 lis2] [n 0])
1134+ (and (not (or (null-list? lis1) (null-list? lis2)))
1135+ (if (pred (car lis1) (car lis2))
1136+ n
1137+ (loop (cdr lis1) (cdr lis2) (fx+ n 1)))))]
1138+ [(pred lis1 lis2 lis3 . lists)
1139+ (check-arg procedure? pred list-index)
1140+ (let loop ([lis1 lis1]
1141+ [lis2 lis2]
1142+ [lis3 lis3]
1143+ [lists lists]
1144+ [n 0])
1145+ (and (not (or (null-list? lis1)
1146+ (null-list? lis2)
1147+ (null-list? lis3)))
1148+ (receive
1149+ (heads tails)
1150+ (%cars+cdrs lists)
1151+ (and (not (null? heads))
1152+ (if (apply pred (car lis1) (car lis2) (car lis3)
1153+ heads)
1154+ n
1155+ (loop (cdr lis1) (cdr lis2) (cdr lis3) tails
1156+ (fx+ n 1)))))))]))
1157+ (define (reverse! lis)
1158+ (let lp ([lis lis] [ans '()])
1159+ (if (null-list? lis)
1160+ ans
1161+ (let ([tail (cdr lis)])
1162+ (set-cdr! lis ans)
1163+ (lp tail lis)))))
1164+ (define (%lset2<= = lis1 lis2)
1165+ (every (lambda (x) (member x lis2 =)) lis1))
1166+ (define lset<=
1167+ (case-lambda
1168+ [(=) (check-arg procedure? = lset<=) #t]
1169+ [(= lis1) (check-arg procedure? = lset<=) #t]
1170+ [(= lis1 lis2)
1171+ (check-arg procedure? = lset<=)
1172+ (or (eq? lis1 lis2) (%lset2<= = lis1 lis2))]
1173+ [(= lis1 lis2 lis3 . lists)
1174+ (check-arg procedure? = lset<=)
1175+ (and (or (eq? lis1 lis2) (%lset2<= = lis1 lis2))
1176+ (or (eq? lis2 lis3) (%lset2<= = lis2 lis3))
1177+ (or (null? lists)
1178+ (let loop ([lis1 lis3]
1179+ [lis2 (car lists)]
1180+ [lists (cdr lists)])
1181+ (and (or (eq? lis1 lis2) (%lset2<= = lis1 lis2))
1182+ (or (null? lists)
1183+ (loop
1184+ lis2
1185+ (car lists)
1186+ (cdr lists)))))))]))
1187+ (define lset=
1188+ (case-lambda
1189+ [(=) (check-arg procedure? = lset=) #t]
1190+ [(= lis1) (check-arg procedure? = lset=) #t]
1191+ [(= lis1 lis2)
1192+ (check-arg procedure? = lset=)
1193+ (or (eq? lis1 lis2)
1194+ (and (%lset2<= = lis1 lis2) (%lset2<= = lis2 lis1)))]
1195+ [(= lis1 lis2 lis3 . lists)
1196+ (check-arg procedure? = lset=)
1197+ (and (or (eq? lis1 lis2)
1198+ (and (%lset2<= = lis1 lis2) (%lset2<= = lis2 lis1)))
1199+ (or (eq? lis2 lis3)
1200+ (and (%lset2<= = lis2 lis3) (%lset2<= = lis3 lis2)))
1201+ (or (null? lists)
1202+ (let loop ([lis1 lis3]
1203+ [lis2 (car lists)]
1204+ [lists (cdr lists)])
1205+ (and (or (eq? lis1 lis2)
1206+ (and (%lset2<= = lis1 lis2)
1207+ (%lset2<= = lis2 lis1)))
1208+ (or (null? lists)
1209+ (loop
1210+ lis2
1211+ (car lists)
1212+ (cdr lists)))))))]))
1213+ (define lset-adjoin
1214+ (case-lambda
1215+ [(= lis) lis]
1216+ [(= lis elt)
1217+ (check-arg procedure? = lset-adjoin)
1218+ (if (member elt lis) lis (cons elt lis))]
1219+ [(= lis elt1 elt2)
1220+ (check-arg procedure? = lset-adjoin)
1221+ (let* ([lis (if (member elt1 lis) lis (cons elt1 lis))]
1222+ [lis (if (member elt2 lis) lis (cons elt2 lis))])
1223+ lis)]
1224+ [(= lis elt1 elt2 elt3 . elts)
1225+ (check-arg procedure? = lset-adjoin)
1226+ (let* ([lis (if (member elt1 lis) lis (cons elt1 lis))]
1227+ [lis (if (member elt2 lis) lis (cons elt2 lis))]
1228+ [lis (if (member elt3 lis) lis (cons elt3 lis))])
1229+ (if (null? elts)
1230+ lis
1231+ (fold
1232+ (lambda (elt ans)
1233+ (if (member elt ans =) ans (cons elt ans)))
1234+ lis
1235+ elts)))]))
1236+ (define lset-union
1237+ (let ([lset-union-2 (lambda (= lis1 lis2)
1238+ (cond
1239+ [(null? lis1) lis2]
1240+ [(null? lis2) lis1]
1241+ [(eq? lis1 lis2) lis1]
1242+ [else
1243+ (fold
1244+ (lambda (elt ans)
1245+ (if (member elt ans =)
1246+ ans
1247+ (cons elt ans)))
1248+ lis1
1249+ lis2)]))])
1250+ (case-lambda
1251+ [(=) (check-arg procedure? = lset-union) '()]
1252+ [(= lis1) (check-arg procedure? = lset-union) lis1]
1253+ [(= lis1 lis2)
1254+ (check-arg procedure? = lset-union)
1255+ (lset-union-2 = lis1 lis2)]
1256+ [(= lis1 lis2 lis3 . lists)
1257+ (check-arg procedure? = lset-union)
1258+ (let* ([lis (lset-union-2 = lis1 lis2)]
1259+ [lis (lset-union-2 = lis lis3)])
1260+ (if (null? lists)
1261+ lis
1262+ (fold
1263+ (lambda (lis2 lis1) (lset-union-2 = lis1 lis2))
1264+ lis
1265+ lists)))])))
1266+ (define lset-union!
1267+ (let ([lset-union-2! (lambda (= lis1 lis2)
1268+ (cond
1269+ [(null? lis1) lis2]
1270+ [(null? lis2) lis1]
1271+ [(eq? lis1 lis2) lis1]
1272+ [else
1273+ (pair-fold
1274+ (lambda (pair ans)
1275+ (let ([elt (car pair)])
1276+ (if (member elt ans =)
1277+ ans
1278+ (begin
1279+ (set-cdr! pair ans)
1280+ pair))))
1281+ lis1
1282+ lis2)]))])
1283+ (case-lambda
1284+ [(=) (check-arg procedure? = lset-union!) '()]
1285+ [(= lis1) (check-arg procedure? = lset-union!) lis1]
1286+ [(= lis1 lis2)
1287+ (check-arg procedure? = lset-union!)
1288+ (lset-union-2! = lis1 lis2)]
1289+ [(= lis1 lis2 lis3 . lists)
1290+ (check-arg procedure? = lset-union!)
1291+ (let* ([lis (lset-union-2! = lis1 lis2)]
1292+ [lis (lset-union-2! = lis lis3)])
1293+ (if (null? lists)
1294+ lis
1295+ (fold
1296+ (lambda (lis1 lis2) (lset-union-2! = lis1 lis2))
1297+ lis
1298+ lists)))])))
1299+ (define lset-intersection
1300+ (case-lambda
1301+ [(= lis1) (check-arg procedure? = lset-intersection) lis1]
1302+ [(= lis1 lis2)
1303+ (check-arg procedure? = lset-intersection)
1304+ (cond
1305+ [(or (null-list? lis1) (eq? lis1 lis2)) lis1]
1306+ [(null-list? lis2) lis2]
1307+ [else (filter (lambda (x) (member x lis2 =)) lis1)])]
1308+ [(= lis1 lis2 lis3 . lists)
1309+ (check-arg procedure? = lset-intersection)
1310+ (cond
1311+ [(or (null-list? lis1)
1312+ (null-list? lis2)
1313+ (null-list? lis3)
1314+ (any null-list? lists))
1315+ '()]
1316+ [(eq? lis2 lis1)
1317+ (if (eq? lis3 lis1)
1318+ (apply lset-intersection = lis1 lists)
1319+ (apply lset-intersection = lis1 lis3 lists))]
1320+ [(or (eq? lis3 lis1) (eq? lis3 lis2))
1321+ (apply lset-intersection = lis1 lis2 lists)]
1322+ [else
1323+ (let* ([lists (remove
1324+ (lambda (lis)
1325+ (or (eq? lis lis1)
1326+ (eq? lis lis2)
1327+ (eq? lis lis3)))
1328+ lists)])
1329+ (filter
1330+ (lambda (x)
1331+ (and (member x lis2 =)
1332+ (member x lis3 =)
1333+ (every (lambda (lis) (member x lis =)) lists)))
1334+ lis1))])]))
1335+ (define lset-intersection!
1336+ (case-lambda
1337+ [(= lis1) (check-arg procedure? = lset-intersection!) lis1]
1338+ [(= lis1 lis2)
1339+ (check-arg procedure? = lset-intersection!)
1340+ (cond
1341+ [(or (null-list? lis2) (eq? lis1 lis2)) lis1]
1342+ [(null-list? lis1) lis2]
1343+ [else (filter! (lambda (x) (member x lis2 =)) lis1)])]
1344+ [(= lis1 lis2 lis3 . lists)
1345+ (check-arg procedure? = lset-intersection!)
1346+ (cond
1347+ [(or (null-list? lis1)
1348+ (null-list? lis2)
1349+ (null-list? lis3)
1350+ (any null-list? lists))
1351+ '()]
1352+ [(eq? lis2 lis1)
1353+ (if (eq? lis3 lis1)
1354+ (apply lset-intersection! = lis1 lists)
1355+ (apply lset-intersection! = lis1 lis3 lists))]
1356+ [(or (eq? lis3 lis1) (eq? lis3 lis2))
1357+ (apply lset-intersection! = lis1 lis2 lists)]
1358+ [else
1359+ (let ([lists (remove
1360+ (lambda (lis)
1361+ (or (eq? lis lis1)
1362+ (eq? lis lis2)
1363+ (eq? lis lis3)))
1364+ lists)])
1365+ (filter!
1366+ (lambda (x)
1367+ (and (member x lis2 =)
1368+ (member x lis3 =)
1369+ (every (lambda (lis) (member x lis =)) lists)))
1370+ lis1))])]))
1371+ (define lset-difference
1372+ (case-lambda
1373+ [(= lis1) (check-arg procedure? = lset-difference) lis1]
1374+ [(= lis1 lis2)
1375+ (check-arg procedure? = lset-difference)
1376+ (cond
1377+ [(null-list? lis2) lis1]
1378+ [(or (null-list? lis1) (eq? lis1 lis2)) '()]
1379+ [else (filter (lambda (x) (not (member x lis2 =))) lis1)])]
1380+ [(= lis1 lis2 lis3 . lists)
1381+ (check-arg procedure? = lset-difference)
1382+ (cond
1383+ [(or (null-list? lis1)
1384+ (eq? lis1 lis2)
1385+ (eq? lis1 lis3)
1386+ (memq lis1 lists))
1387+ '()]
1388+ [(null? lis2)
1389+ (if (null? lis3)
1390+ (apply lset-difference lis1 lists)
1391+ (apply lset-difference lis1 lis3 lists))]
1392+ [(or (null? lis3) (eq? lis3 lis2))
1393+ (apply lset-difference lis1 lis2 lists)]
1394+ [else
1395+ (let ([lists (remove
1396+ (lambda (lis)
1397+ (or (null? lis)
1398+ (eq? lis lis2)
1399+ (eq? lis lis3)))
1400+ lists)])
1401+ (filter
1402+ (lambda (x)
1403+ (and (not (member x lis2 =))
1404+ (not (member x lis3 =))
1405+ (every
1406+ (lambda (lis) (not (member x lis =)))
1407+ lists)))
1408+ lis1))])]))
1409+ (define lset-difference!
1410+ (case-lambda
1411+ [(= lis1) (check-arg procedure? = lset-difference!) lis1]
1412+ [(= lis1 lis2)
1413+ (check-arg procedure? = lset-difference!)
1414+ (cond
1415+ [(null-list? lis2) lis1]
1416+ [(or (null-list? lis1) (eq? lis1 lis2)) '()]
1417+ [else (filter! (lambda (x) (not (member x lis2 =))) lis1)])]
1418+ [(= lis1 lis2 lis3 . lists)
1419+ (check-arg procedure? = lset-difference!)
1420+ (cond
1421+ [(or (null-list? lis1)
1422+ (eq? lis1 lis2)
1423+ (eq? lis1 lis3)
1424+ (memq lis1 lists))
1425+ '()]
1426+ [(null? lis2)
1427+ (if (null? lis3)
1428+ (apply lset-difference lis1 lists)
1429+ (apply lset-difference lis1 lis3 lists))]
1430+ [(or (null? lis3) (eq? lis3 lis2))
1431+ (apply lset-difference lis1 lis2 lists)]
1432+ [else
1433+ (let ([lists (remove
1434+ (lambda (lis)
1435+ (or (null? lis)
1436+ (eq? lis lis2)
1437+ (eq? lis lis3)))
1438+ lists)])
1439+ (filter!
1440+ (lambda (x)
1441+ (and (not (member x lis2 =))
1442+ (every
1443+ (lambda (lis) (not (member x lis =)))
1444+ lists)))
1445+ lis1))])]))
1446+ (define lset-xor
1447+ (let ([lset-xor-2 (lambda (= b a)
1448+ (receive
1449+ (a-b a-int-b)
1450+ (lset-diff+intersection = a b)
1451+ (cond
1452+ [(null? a-b) (lset-difference = b a)]
1453+ [(null? a-int-b) (append b a)]
1454+ [else
1455+ (fold
1456+ (lambda (xb ans)
1457+ (if (member xb a-int-b =)
1458+ ans
1459+ (cons xb ans)))
1460+ a-b
1461+ b)])))])
1462+ (case-lambda
1463+ [(=) (check-arg procedure? = lset-xor) '()]
1464+ [(= a) (check-arg procedure? = lset-xor) a]
1465+ [(= a b)
1466+ (check-arg procedure? = lset-xor)
1467+ (lset-xor-2 = b a)]
1468+ [(= a b c . lists)
1469+ (check-arg procedure? = lset-xor)
1470+ (let* ([lis (lset-xor-2 = b a)] [lis (lset-xor-2 = c lis)])
1471+ (if (null? lists)
1472+ lis
1473+ (fold
1474+ (lambda (b a) (lset-xor-2 = b a))
1475+ lis
1476+ lists)))])))
1477+ (define lset-xor!
1478+ (let ([lset-xor-2! (lambda (= b a)
1479+ (receive
1480+ (a-b a-int-b)
1481+ (lset-diff+intersection! = a b)
1482+ (cond
1483+ [(null? a-b) (lset-difference! = b a)]
1484+ [(null? a-int-b) (append! b a)]
1485+ [else
1486+ (pair-fold
1487+ (lambda (b-pair ans)
1488+ (if (member (car b-pair) a-int-b =)
1489+ ans
1490+ (begin
1491+ (set-cdr! b-pair ans)
1492+ b-pair)))
1493+ a-b
1494+ b)])))])
1495+ (case-lambda
1496+ [(=) (check-arg procedure? = lset-xor!) '()]
1497+ [(= a) (check-arg procedure? = lset-xor!) a]
1498+ [(= a b)
1499+ (check-arg procedure? = lset-xor!)
1500+ (lset-xor-2! = b a)]
1501+ [(= a b c . lists)
1502+ (check-arg procedure? = lset-xor!)
1503+ (let* ([lis (lset-xor-2! = b a)]
1504+ [lis (lset-xor-2! = c lis)])
1505+ (if (null? lists)
1506+ lis
1507+ (fold
1508+ (lambda (b a) (lset-xor-2! = b a))
1509+ lis
1510+ lists)))])))
1511+ (define lset-diff+intersection
1512+ (case-lambda
1513+ [(= lis1)
1514+ (check-arg procedure? = lset-diff+intersection)
1515+ (values lis1 '())]
1516+ [(= lis1 lis2)
1517+ (check-arg procedure? = lset-diff+intersection)
1518+ (cond
1519+ [(or (null-list? lis1) (eq? lis1 lis2)) (values '() lis1)]
1520+ [(null-list? lis2) (values lis1 '())]
1521+ [else
1522+ (partition
1523+ (lambda (elt) (not (member elt lis2 =)))
1524+ lis1)])]
1525+ [(= lis1 lis2 lis3 . lists)
1526+ (check-arg procedure? = lset-diff+intersection)
1527+ (cond
1528+ [(or (null-list? lis1)
1529+ (eq? lis1 lis2)
1530+ (eq? lis1 lis3)
1531+ (memq lis1 lists))
1532+ (values '() lis1)]
1533+ [(null-list? lis2)
1534+ (if (null-list? lis3)
1535+ (apply lset-diff+intersection = lis1 lists)
1536+ (apply lset-diff+intersection = lis1 lis3 lists))]
1537+ [(or (null-list? lis3) (eq? lis3 lis2))
1538+ (apply lset-diff+intersection = lis1 lis2 lists)]
1539+ [else
1540+ (let ([lists (remove
1541+ (lambda (lis)
1542+ (or (null? lis)
1543+ (eq? lis lis2)
1544+ (eq? lis lis3)))
1545+ lists)])
1546+ (partition
1547+ (lambda (elt)
1548+ (not (or (member elt lis2 =)
1549+ (member elt lis3 =)
1550+ (any (lambda (lis) (member elt lis =))
1551+ lists))))
1552+ lis1))])]))
1553+ (define lset-diff+intersection!
1554+ (case-lambda
1555+ [(= lis1)
1556+ (check-arg procedure? = lset-diff+intersection!)
1557+ (values lis1 '())]
1558+ [(= lis1 lis2)
1559+ (check-arg procedure? = lset-diff+intersection!)
1560+ (cond
1561+ [(or (null-list? lis1) (eq? lis1 lis2)) (values '() lis1)]
1562+ [(null-list? lis2) (values lis1 '())]
1563+ [else
1564+ (partition!
1565+ (lambda (elt) (not (member elt lis2 =)))
1566+ lis1)])]
1567+ [(= lis1 lis2 lis3 . lists)
1568+ (check-arg procedure? = lset-diff+intersection!)
1569+ (cond
1570+ [(or (null-list? lis1)
1571+ (eq? lis1 lis2)
1572+ (eq? lis1 lis3)
1573+ (memq lis1 lists))
1574+ (values '() lis1)]
1575+ [(null-list? lis2)
1576+ (if (null-list? lis3)
1577+ (apply lset-diff+intersection! = lis1 lists)
1578+ (apply lset-diff+intersection! = lis1 lis3 lists))]
1579+ [(or (null-list? lis3) (eq? lis3 lis2))
1580+ (apply lset-diff+intersection = lis1 lis2 lists)]
1581+ [else
1582+ (let ([lists (remove
1583+ (lambda (lis)
1584+ (or (null? lis)
1585+ (eq? lis lis2)
1586+ (eq? lis lis3)))
1587+ lists)])
1588+ (partition!
1589+ (lambda (elt)
1590+ (not (or (member elt lis2 =)
1591+ (member elt lis3 =)
1592+ (any (lambda (lis) (member elt lis =))
1593+ lists))))
1594+ lis1))])]))))))