1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Mike Sperber
4
5; The (rnrs lists (6)) library.
6
7(define (assert-procedure who obj)
8  (if (not (procedure? obj))
9      (assertion-violation who "not a procedure" obj)))
10
11(define (find proc list)
12  (assert-procedure 'find proc)
13  (let loop ((list list))
14    (cond
15     ((null? list) #f)
16     ((proc (car list)) (car list))
17     (else (loop (cdr list))))))
18
19(define (check-nulls who the-list the-lists lists)
20  (for-each (lambda (list)
21	      (if (not (null? list))
22		  (apply assertion-violation who
23			 "argument lists don't have the same size"
24			 list lists)))
25	    lists))
26
27(define (for-all proc list . lists)
28  (assert-procedure 'for-all proc)
29  (cond
30   ((null? lists)
31    (for-all1 proc list))
32   ((null? list)
33    (check-nulls 'for-all list lists lists)
34    #t)
35   (else
36    (let loop ((list list) (lists lists))
37      (let ((next (cdr list)))
38	(cond
39	 ((null? next)
40	  (apply proc (car list) (map car lists)))
41	 ((apply proc (car list) (map car lists))
42	  (loop next (map cdr lists)))
43	 (else #f)))))))
44
45(define (for-all1 proc list)
46  (if (null? list)
47      #t
48      (let loop ((list list))
49	(let ((next (cdr list)))
50	  (cond
51	   ((null? next) (proc (car list)))
52	   ((proc (car list)) (loop next))
53	   (else #f))))))
54
55(define (exists proc list . lists)
56  (assert-procedure 'exists proc)
57  (cond
58   ((null? lists)
59    (exists1 proc list))
60   ((null? list)
61    (check-nulls 'exists list lists lists)
62    #f)
63   (else
64    (let loop ((list list) (lists lists))
65      (let ((next (cdr list)))
66	(if (null? next)
67	    (apply proc (car list) (map car lists))
68	    (or (apply proc (car list) (map car lists))
69		(loop next (map cdr lists)))))))))
70
71(define (exists1 proc list)
72  (if (null? list)
73      #f
74      (let loop ((list list))
75	(let ((next (cdr list)))
76	  (if (null? next)
77	      (proc (car list))
78	      (or (proc (car list))
79		  (loop next)))))))
80
81(define (filter proc list)
82  (assert-procedure 'filter proc)
83  (let loop ((list list) (r '()))
84    (cond ((null? list)
85	   (reverse r))
86          ((proc (car list))
87	   (loop (cdr list) (cons (car list) r)))
88          (else
89	   (loop (cdr list) r)))))
90
91(define (partition proc list)
92  (assert-procedure 'partition proc)
93  (let loop ((list list) (yes '()) (no '()))
94    (cond ((null? list)
95           (values (reverse yes) (reverse no)))
96          ((proc (car list))
97           (loop (cdr list) (cons (car list) yes) no))
98          (else
99           (loop (cdr list) yes (cons (car list) no))))))
100
101(define (fold-left combine nil the-list . the-lists)
102  (assert-procedure 'fold-left combine)
103  (if (null? the-lists)
104      (fold-left1 combine nil the-list)
105      (let loop ((accum nil) (list the-list) (lists the-lists))
106	(if (null? list)
107	    (begin
108	      (check-nulls 'fold-left the-list the-lists lists)
109	      accum)
110	    (loop (apply combine accum (car list) (map car lists))
111		  (cdr list)
112		  (map cdr lists))))))
113
114(define (fold-left1 combine nil list)
115  (let loop ((accum nil) (list list))
116    (if (null? list)
117	accum
118	(loop (combine accum (car list))
119	      (cdr list)))))
120
121
122(define (fold-right combine nil the-list . the-lists)
123  (assert-procedure 'fold-right combine)
124  (if (null? the-lists)
125      (fold-right1 combine nil the-list)
126      (let recur ((list the-list) (lists the-lists))
127	(if (null? list)
128	    (begin
129	      (check-nulls 'fold-right the-list the-lists lists)
130	      nil)
131	    (apply combine
132		   (car list)
133		   (append (map car lists)
134			   (cons (recur (cdr list) (map cdr lists))
135				 '())))))))
136
137(define (fold-right1 combine nil list)
138  (let recur ((list list))
139    (if (null? list)
140	nil
141	(combine (car list) (recur (cdr list))))))
142
143(define (remp proc list)
144  (assert-procedure 'remp proc)
145  (let recur ((list list) (res '()))
146    (cond ((null? list) (reverse res))
147	  ((proc (car list))
148	   (append-reverse! res (recur (cdr list) '())))
149	  (else
150	   (recur (cdr list) (cons (car list) res))))))
151
152;; Poor man's inliner
153(define-syntax define-remove-like
154  (syntax-rules ()
155    ((define-remove-like ?name ?equal?)
156     (define (?name obj list)
157       (let recur ((list list) (res '()))
158	 (cond ((null? list) (reverse res))
159	       ((?equal? obj (car list))
160		(append-reverse! res (recur (cdr list) '())))
161	       (else
162		(recur (cdr list) (cons (car list) res)))))))))
163
164(define-remove-like remove equal?)
165(define-remove-like remv eqv?)
166(define-remove-like remq eq?)
167
168(define (append-reverse! l1 l2)
169  (let loop ((list l1) (res l2))
170    (cond ((null? list)
171	   res)
172	  (else
173	   (let ((next (cdr list)))
174	     (set-cdr! list res)
175	     (loop next list))))))
176
177(define (memp proc list)
178  (assert-procedure 'member proc)
179  (let loop ((list list))
180    (cond ((null? list) #f)
181	  ((proc (car list)) list)
182	  (else (loop (cdr list))))))
183
184(define-syntax define-member-like
185  (syntax-rules ()
186    ((define-member-like ?name ?equal?)
187     (define (?name obj list)
188       (let loop ((list list))
189	 (cond ((null? list) #f)
190	       ((?equal? obj (car list)) list)
191	       (else (loop (cdr list)))))))))
192
193; take the versions from `scheme'
194;(define-member-like member equal?)
195;(define-member-like memv eqv?)
196;(define-member-like memq eq?)
197
198(define (assp proc alist)
199  (assert-procedure 'assp proc)
200  (let loop ((alist alist))
201    (if (null? alist)
202	#f
203	(let ((p (car alist)))
204	  (if (proc (car p))
205	      p
206	      (loop (cdr alist)))))))
207
208(define-syntax define-assoc-like
209  (syntax-rules ()
210    ((define-assoc-like ?name ?equal?)
211     (define (?name obj alist)
212       (let loop ((alist alist))
213	 (if (null? alist)
214	     #f
215	     (let ((p (car alist)))
216	       (if (?equal? obj (car p))
217		   p
218		   (loop (cdr alist))))))))))
219
220; take the versions from `scheme'
221;(define-member-like assoc equal?)
222;(define-member-like assv eqv?)
223;(define-member-like assq eq?)
224
225(define (cons* obj . objs)
226  (if (null? objs)
227      obj
228      (cons obj (apply cons* objs))))
229