1;; The (rnrs lists (6)) library. Contains some code from Kawa's SRFI-1
2;; implementation (i.e. the reference implementation, which is
3;; Copyright (c) 1998, 1999 by Olin Shivers). Documentation strings
4;; are adapted from the text of the R6RS List utilities library
5;; specification. The rest is Copyright (c) 2011 by Jamison Hope.
6
7(module-name kawa.lib.rnrs.lists)
8(module-export find for-all exists filter partition fold-left
9               fold-right remp remove remv remq memp member memv memq
10               assp assoc assv assq cons*)
11(require kawa.lib.prim_imports)
12(require kawa.lib.std_syntax)
13(require kawa.lib.syntax)
14(require kawa.lib.misc)
15(require kawa.lib.lists "../lists.scm")
16
17;;; Helper Functions
18
19(define (complement (proc ::procedure)) ::procedure
20  (lambda (x) (not (proc x))))
21
22;; car+cdr, %cars+cdrs, %cars+cdrs/pair, %cdrs, %cars+ taken from
23;; srfi1.scm
24(define (car+cdr (pair ::pair)) (values (car pair) (cdr pair)))
25
26(define (%cars+cdrs (lists ::list))
27  "LISTS is a (not very long) non-empty list of lists. Return two
28lists: the cars & the cdrs of the lists. However, if any of the lists
29is empty, just abort and return [() ()]."
30  (call-with-current-continuation
31   (lambda (abort)
32     (let recur ((lists lists))
33       (if (pair? lists)
34           (let-values (((list other-lists) (car+cdr lists)))
35             (if (null? list) (abort '() '()) ; LIST is empty -- bail out
36                 (let-values (((a d) (car+cdr list))
37                              ((cars cdrs) (recur other-lists)))
38                   (values (cons a cars) (cons d cdrs)))))
39           (values '() '()))))))
40
41(define (%cars+cdrs/pair (lists ::list)) ::pair
42  "Return the `%cars+cdrs' result as a pair instead of a multiple
43value return.  Kawa finds it easier to optimize a tail recursive loop
44when the `%cars+cdrs' logic is called this way."
45  (let-values (((cars cdrs) (%cars+cdrs lists)))
46    (cons cars cdrs)))
47
48(define (%cdrs lists)
49  "Return (map cdr lists). However, if any element of LISTS is empty,
50just abort and return '()."
51  (call-with-current-continuation
52   (lambda (abort)
53     (let recur ((lists lists))
54       (if (pair? lists)
55           (let ((lis (car lists)))
56             (if (null? lis) (abort '())
57                 (cons (cdr lis) (recur (cdr lists)))))
58           '())))))
59
60(define (%cars+ (lists ::list) last-elt) ::list
61  ; (append! (map car lists) (list last-elt))
62  (let recur ((lists lists))
63    (if (pair? lists) (cons (caar lists) (recur (cdr lists)))
64        (list last-elt))))
65
66;;; Exported Functions
67
68;;; find
69(define (find (proc ::procedure) (lst ::list))
70  "PROC should accept one argument and return a single value. PROC
71should not mutate LST. The `find' procedure applies PROC to the
72elements of LST in order. If PROC returns a true value for an
73element, `find' immediately returns that element. If PROC returns #f
74for all elements of the list, `find' returns #f. PROC is always called
75in the same dynamic environment as `find' itself."
76  (let loop ((list lst))
77    (if (null? list) #f
78        (let ((x (car list)))
79          (if (proc x) x
80              (loop (cdr list)))))))
81
82;;; for-all, exists (based upon SRFI-1 every, any)
83(define (for-all (proc ::procedure) (list1 ::list) . lists)
84  "The LISTs should all have the same length, and PROC should accept N
85arguments and return a single value. PROC should not mutate the LIST
86arguments.
87
88For natural numbers I=0,1,..., the `for-all' procedure successively
89applies PROC to arguments X_I^1 ... X_I^N, where X_I^J is the Ith
90element of LIST_J, until #f is returned. If PROC returns true values
91for all but the last element of LIST_1, `for-all' performs a tail call
92of PROC on the Kth elements, where K is the length of LIST_1. If PROC
93returns #f on any set of elements, `for-all' returns #f after the
94first such application of PROC. If the LISTs are all empty, `for-all'
95returns #t.
96
97PROC is always called in the same dynamic environment as `for-all'
98itself."
99  (if (pair? lists)
100      ;; N-ary case
101      (let-values (((heads tails) (%cars+cdrs (cons list1 lists))))
102        (or (not (pair? heads))
103            (let lp ((heads heads) (tails tails))
104              (let-values (((next-heads next-tails) (%cars+cdrs tails)))
105                (if (pair? next-heads)
106                    (and (apply proc heads) (lp next-heads next-tails))
107                    (apply proc heads)))))) ; Last PROC app is tail call.
108      ;; Fast path
109      (or (null? list1)
110          (let lp ((head (car list1)) (tail (cdr list1)))
111            (if (null? tail)
112                (proc head)             ; Last PROC app is tail call.
113                (and (proc head) (lp (car tail) (cdr tail))))))))
114
115(define (exists (proc ::procedure) (list1 ::list) . lists)
116  "The LISTs should all have the same length, and PROC should accept N
117arguments and return a single value. PROC should not mutate the LIST
118arguments.
119
120For natural numbers I=0,1,..., the `exists' procedure applies PROC
121successively to arguments X_I^1 ... X_I^N, where X_I^N is the Ith
122element of LIST_J, until a true value is returned. If PROC returns #f
123for all but the last elements of the LISTs, `exists' performs a tail
124call of PROC on the Kth elements, where K is the length of LIST_1. If
125PROC returns a true value on any set of elements, `exists' returns
126that value after the first such application of PROC. If the LISTs are
127all empty, `exists' returns #f.
128
129PROC is always called in the same dynamic environment as `exists'
130itself."
131  (if (pair? lists)
132      ;; N-ary case
133      (let-values (((heads tails) (%cars+cdrs (cons list1 lists))))
134        (and (pair? heads)
135             (let lp ((heads heads) (tails tails))
136               (let* ((split (%cars+cdrs/pair tails))
137                      (next-heads (car split))
138                      (next-tails (cdr split)))
139                 (if (pair? next-heads)
140                     (or (apply proc heads) (lp next-heads next-tails))
141                     (apply proc heads)))))) ; Last PROC app is tail call.
142      ;; Fast path
143      (and (not (null? list1))
144           (let lp ((head (car list1)) (tail (cdr list1)))
145             (if (null? tail)
146                 (proc head)            ; Last PROC app is tail call.
147                 (or (proc head) (lp (car tail) (cdr tail))))))))
148
149;;; filter, partition
150(define (filter (proc ::procedure) (lst ::list))
151  "PROC should accept one argument and return a single value. PROC
152should not mutate LST.
153
154The `filter' procedure applies PROC to each element of LST and
155returns a list of the elements of LST for which PROC returned a true
156value. The elements of the result list are in the same order as they
157appear in the input list. PROC is always called in the same dynamic
158environment as `filter' itself. If multiple returns occur from
159`filter', the return values returned by earlier returns are not
160mutated."
161  (let recur ((list lst) (res '()))
162    (if (null? list)
163        (reverse! res)
164        (let ((head (car list))
165              (tail (cdr list)))
166          (if (proc head)
167              (recur tail (cons head res))
168              (recur tail res))))))
169
170(define (partition (proc ::procedure) (lst ::list))
171  "PROC should accept one argument and return a single value. PROC
172should not mutate LST.
173
174The `partition' procedure applies PROC to each element of LST, and
175returns two values, the first one a list of the elements of LST for
176which PROC returned a true value, and the second a list of the
177elements of LST for which PROC returned #f. The elements of the
178result lists are in the same order as they appear in the input
179list. PROC is always called in the same dynamic environment as
180`partition' itself. If multiple returns occur from `partition', the
181return values returned by earlier returns are not mutated."
182  (let loop ((list lst) (in '()) (out '()))
183    (if (null? list)
184        (values (reverse! in) (reverse! out))
185        (let ((head (car list))
186              (tail (cdr list)))
187          (if (proc head)
188              (loop tail (cons head in) out)
189              (loop tail in (cons head out)))))))
190
191;;; fold-left
192(define (fold-left (combine ::procedure) nil (list1 ::list) . lists)
193  "The LISTs should all have the same length. COMBINE must be a
194procedure. It should accept one more argument than there are LISTs and
195return a single value. It should not mutate the LIST arguments. The
196`fold-left' procedure iterates the COMBINE procedure over an
197accumulator value and the elements of the LISTs from left to right,
198starting with an accumulator value of NIL. More specifically,
199`fold-left' returns NIL if the LISTs are empty. If they are not empty,
200COMBINE is first applied to NIL and the respective first elements of
201the LISTs in order. The result becomes the new accumulator value, and
202COMBINE is applied to the new accumulator value and the respective
203next elements of the LISTs. This step is repeated until the end of the
204list is reached; then the accumulator value is returned. COMBINE is
205always called in the same dynamic environment as `fold-left' itself."
206  (if (pair? lists)
207      ;; N-ary case
208      (let lp ((lists (cons list1 lists)) (ans nil))
209        (let-values (((cars cdrs) (%cars+cdrs lists)))
210          (if (null? cars) ans ; Done.
211              (lp cdrs (apply combine ans cars)))))
212      ;; Fast path
213      (let lp ((list list1) (ans nil))
214        (if (null? list) ans
215            (lp (cdr list) (combine ans (car list)))))))
216
217;;; fold-right
218(define (fold-right (combine ::procedure) nil (list1 ::list) . lists)
219  "The LISTs should all have the same length. COMBINE must be a
220procedure. It should accept one more argument than there are LISTs and
221return a single value. COMBINE should not mutate the LIST
222arguments. The `fold-right' procedure iterates the COMBINE procedure
223over the elements of the LISTs from right to left and an accumulator
224value, starting with an accumulator value of NIL. More specifically,
225`fold-right' returns NIL if the LISTs are empty. If they are not
226empty, COMBINE is first applied to the respective last elements of the
227LISTs in order and NIL. The result becomes the new accumulator value,
228and COMBINE is applied to the respective previous elements of the
229LISTs and the new accumulator value. This step is repeated until the
230beginning of the list is reached; then the accumulator value is
231returned. PROC is always called in the same dynamic environment as
232`fold-right' itself."
233  (if (pair? lists)
234      ;; N-ary case
235      (let recur ((lists (cons list1 lists)))
236        (let ((cdrs (%cdrs lists)))
237          (if (null? cdrs) nil
238              (apply combine (%cars+ lists (recur cdrs))))))
239      ;; Fast path
240      (let recur ((list list1))
241        (if (null? list) nil
242            (let ((head (car list)))
243              (combine head (recur (cdr list))))))))
244
245;;; remp, remove, remv, remq
246(define (remp (proc ::procedure) (lst ::list)) ::list
247  "PROC should accept one argument and return a single value. PROC
248should not mutate LIST.
249
250The `remp' procedure applies PROC to each element of LIST and returns
251a list of the elements of LIST for which PROC returned #f. PROC is
252always called in the same dynamic environment as `remp' itself. The
253elements of the result list are in the same order as they appear in
254the input list. If multiple returns occur from `remp', the return
255values returned by earlier returns are not mutated."
256  (filter (complement proc) lst))
257
258(define (remove obj (lst ::list)) ::list
259  "The `remove' procedure returns a list of the elements that are not
260OBJ. `remove' uses `equal?' to compare OBJ with the elements of
261LST. The elements of the result list are in the same order as they
262appear in the input list."
263  (filter (lambda (o) (not (equal? o obj))) lst))
264
265(define (remv obj (lst ::list)) ::list
266  "The `remv' procedure returns a list of the elements that are not
267OBJ. `remv' uses `eqv?' to compare OBJ with the elements of LST. The
268elements of the result list are in the same order as they appear in
269the input list."
270  (filter (lambda (o) (not (eqv? o obj))) lst))
271
272(define (remq obj (lst ::list)) ::list
273  "The `remq' procedure returns a list of the elements that are not
274OBJ. `remq' uses `eq?' to compare OBJ with the elements of LIST. The
275elements of the result list are in the same order as they appear in
276the input list."
277  (filter (lambda (o) (not (eq? o obj))) lst))
278
279;;; memp, member, memv, memq
280(define (memp (proc ::procedure) (lst ::list))
281  "PROC should accept one argument and return a single value. PROC
282should not mutate LST.
283
284`memp' returns the first sublist of LST whose car satisfies a given
285condition, where the sublists of LST are the lists returned by
286(`list-tail' LST K) for K less than the length of LST. The `memp'
287procedure applies PROC to the cars of the sublists of LST until it
288finds one for which PROC returns a true value. PROC is always called
289in the same dynamic environment as `memp' itself. If LST does not
290contain an element satisfying the condition, then #f (not the empty
291list) is returned."
292  (let recur ((list lst))
293    (cond ((null? list) #f)
294          ((proc (car list)) list)
295          (else (recur (cdr list))))))
296
297;; member, memv, and memq are defined in kawa.lib.lists
298;; (define (member obj (lst ::list)))
299;; (define (memv obj (lst ::list)))
300;; (define (memq obj (lst ::list)))
301
302;;; assp, assoc, assv, assq
303(define (assp (proc ::procedure) (alist ::list))
304  "ALIST (for \"association list\") should be a list of pairs. PROC
305should accept one argument and return a single value. PROC should not
306mutate ALIST.
307
308The `assp' procedure finds the first pair in ALIST whose car field
309satisfies a given condition, and returns that pair without traversing
310ALIST further. If no pair in ALIST satisfies the condition, then #f is
311returned. The `assp' procedure successively applies PROC to the car
312fields of ALIST and looks for a pair for which it returns a true
313value. PROC is always called in the same dynamic environment as `assp'
314itself."
315  (let recur ((alist alist))
316    (cond ((null? alist) #f)
317          ((proc (caar alist)) (car alist))
318          (else (recur (cdr alist))))))
319
320;; assoc, assv, and assq are defined in kawa.lib.lists
321;; (define (assoc obj (alist ::list)))
322;; (define (assv obj (alist ::list)))
323;; (define (assq obj (alist ::list)))
324
325;;; cons*
326(define (cons* #!rest (args :: object[]))
327  "If called with at least two arguments, `cons*' returns a freshly
328allocated chain of pairs whose cars are OBJ1,...,OBJN, and whose last
329cdr is OBJ. If called with only one argument, `cons*' returns that
330argument."
331  (gnu.lists.LList:consX args))
332