Commit | Line | Data |
---|---|---|
6a4d3cfd JB |
1 | ;;;; common-list.scm --- COMMON LISP list functions for Scheme |
2 | ;;;; | |
cd5fea8d | 3 | ;;;; Copyright (C) 1995, 1996, 1997, 2001, 2006 Free Software Foundation, Inc. |
c771038b | 4 | ;;;; |
73be1d9e MV |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
9 | ;;;; |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
6a4d3cfd | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
c771038b TTN |
18 | ;;;; |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; These procedures are exported: | |
23 | ;; (adjoin e l) | |
24 | ;; (union l1 l2) | |
25 | ;; (intersection l1 l2) | |
26 | ;; (set-difference l1 l2) | |
27 | ;; (reduce-init p init l) | |
28 | ;; (reduce p l) | |
29 | ;; (some pred l . rest) | |
30 | ;; (every pred l . rest) | |
31 | ;; (notany pred . ls) | |
32 | ;; (notevery pred . ls) | |
33 | ;; (count-if pred l) | |
34 | ;; (find-if pred l) | |
35 | ;; (member-if pred l) | |
36 | ;; (remove-if pred l) | |
37 | ;; (remove-if-not pred l) | |
38 | ;; (delete-if! pred l) | |
39 | ;; (delete-if-not! pred l) | |
40 | ;; (butlast lst n) | |
41 | ;; (and? . args) | |
42 | ;; (or? . args) | |
43 | ;; (has-duplicates? lst) | |
44 | ;; (pick p l) | |
45 | ;; (pick-mappings p l) | |
46 | ;; (uniq l) | |
47 | ;; | |
48 | ;; See docstrings for each procedure for more info. See also module | |
49 | ;; `(srfi srfi-1)' for a complete list handling library. | |
50 | ||
51 | ;;; Code: | |
6a4d3cfd | 52 | \f |
1a179b03 MD |
53 | (define-module (ice-9 common-list) |
54 | :export (adjoin union intersection set-difference reduce-init reduce | |
55 | some every notany notevery count-if find-if member-if remove-if | |
56 | remove-if-not delete-if! delete-if-not! butlast and? or? | |
57 | has-duplicates? pick pick-mappings uniq)) | |
a6401ee0 JB |
58 | |
59 | ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme | |
60 | ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. | |
61 | ; | |
62 | ;Permission to copy this software, to redistribute it, and to use it | |
63 | ;for any purpose is granted, subject to the following restrictions and | |
64 | ;understandings. | |
65 | ; | |
66 | ;1. Any copy made of this software must include this copyright notice | |
67 | ;in full. | |
68 | ; | |
69 | ;2. I have made no warrantee or representation that the operation of | |
70 | ;this software will be error-free, and I am under no obligation to | |
71 | ;provide any services, by way of maintenance, update, or otherwise. | |
72 | ; | |
73 | ;3. In conjunction with products arising from the use of this | |
74 | ;material, there shall be no use of my name in any advertising, | |
75 | ;promotional, or sales literature without prior written consent in | |
76 | ;each case. | |
77 | ||
1a179b03 | 78 | (define (adjoin e l) |
c771038b | 79 | "Return list L, possibly with element E added if it is not already in L." |
16693054 | 80 | (if (memq e l) l (cons e l))) |
a6401ee0 | 81 | |
1a179b03 | 82 | (define (union l1 l2) |
c771038b TTN |
83 | "Return a new list that is the union of L1 and L2. |
84 | Elements that occur in both lists occur only once in | |
85 | the result list." | |
a6401ee0 JB |
86 | (cond ((null? l1) l2) |
87 | ((null? l2) l1) | |
88 | (else (union (cdr l1) (adjoin (car l1) l2))))) | |
89 | ||
1a179b03 | 90 | (define (intersection l1 l2) |
c771038b TTN |
91 | "Return a new list that is the intersection of L1 and L2. |
92 | Only elements that occur in both lists occur in the result list." | |
e5d2c2fa DH |
93 | (if (null? l2) l2 |
94 | (let loop ((l1 l1) (result '())) | |
95 | (cond ((null? l1) (reverse! result)) | |
96 | ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result))) | |
97 | (else (loop (cdr l1) result)))))) | |
a6401ee0 | 98 | |
1a179b03 | 99 | (define (set-difference l1 l2) |
16693054 | 100 | "Return elements from list L1 that are not in list L2." |
e5d2c2fa DH |
101 | (let loop ((l1 l1) (result '())) |
102 | (cond ((null? l1) (reverse! result)) | |
103 | ((memv (car l1) l2) (loop (cdr l1) result)) | |
104 | (else (loop (cdr l1) (cons (car l1) result)))))) | |
a6401ee0 | 105 | |
1a179b03 | 106 | (define (reduce-init p init l) |
16693054 | 107 | "Same as `reduce' except it implicitly inserts INIT at the start of L." |
a6401ee0 JB |
108 | (if (null? l) |
109 | init | |
110 | (reduce-init p (p init (car l)) (cdr l)))) | |
111 | ||
1a179b03 | 112 | (define (reduce p l) |
c771038b TTN |
113 | "Combine all the elements of sequence L using a binary operation P. |
114 | The combination is left-associative. For example, using +, one can | |
115 | add up all the elements. `reduce' allows you to apply a function which | |
16693054 GB |
116 | accepts only two arguments to more than 2 objects. Functional |
117 | programmers usually refer to this as foldl." | |
a6401ee0 JB |
118 | (cond ((null? l) l) |
119 | ((null? (cdr l)) (car l)) | |
120 | (else (reduce-init p (car l) (cdr l))))) | |
121 | ||
1a179b03 | 122 | (define (some pred l . rest) |
16693054 | 123 | "PRED is a boolean function of as many arguments as there are list |
c771038b TTN |
124 | arguments to `some', i.e., L plus any optional arguments. PRED is |
125 | applied to successive elements of the list arguments in order. As soon | |
126 | as one of these applications returns a true value, return that value. | |
127 | If no application returns a true value, return #f. | |
128 | All the lists should have the same length." | |
a6401ee0 JB |
129 | (cond ((null? rest) |
130 | (let mapf ((l l)) | |
131 | (and (not (null? l)) | |
132 | (or (pred (car l)) (mapf (cdr l)))))) | |
133 | (else (let mapf ((l l) (rest rest)) | |
134 | (and (not (null? l)) | |
135 | (or (apply pred (car l) (map car rest)) | |
136 | (mapf (cdr l) (map cdr rest)))))))) | |
137 | ||
1a179b03 | 138 | (define (every pred l . rest) |
16693054 GB |
139 | "Return #t iff every application of PRED to L, etc., returns #t. |
140 | Analogous to `some' except it returns #t if every application of | |
141 | PRED is #t and #f otherwise." | |
a6401ee0 JB |
142 | (cond ((null? rest) |
143 | (let mapf ((l l)) | |
144 | (or (null? l) | |
145 | (and (pred (car l)) (mapf (cdr l)))))) | |
146 | (else (let mapf ((l l) (rest rest)) | |
147 | (or (null? l) | |
148 | (and (apply pred (car l) (map car rest)) | |
149 | (mapf (cdr l) (map cdr rest)))))))) | |
150 | ||
1a179b03 | 151 | (define (notany pred . ls) |
16693054 | 152 | "Return #t iff every application of PRED to L, etc., returns #f. |
59dd1852 MV |
153 | Analogous to some but returns #t if no application of PRED returns a |
154 | true value or #f as soon as any one does." | |
16693054 GB |
155 | (not (apply some pred ls))) |
156 | ||
1a179b03 | 157 | (define (notevery pred . ls) |
16693054 GB |
158 | "Return #t iff there is an application of PRED to L, etc., that returns #f. |
159 | Analogous to some but returns #t as soon as an application of PRED returns #f, | |
160 | or #f otherwise." | |
161 | (not (apply every pred ls))) | |
162 | ||
1a179b03 | 163 | (define (count-if pred l) |
c771038b | 164 | "Return the number of elements in L for which (PRED element) returns true." |
d69947f7 KN |
165 | (let loop ((n 0) (l l)) |
166 | (cond ((null? l) n) | |
167 | ((pred (car l)) (loop (+ n 1) (cdr l))) | |
168 | (else (loop n (cdr l)))))) | |
169 | ||
1a179b03 | 170 | (define (find-if pred l) |
c771038b TTN |
171 | "Search for the first element in L for which (PRED element) returns true. |
172 | If found, return that element, otherwise return #f." | |
a6401ee0 | 173 | (cond ((null? l) #f) |
16693054 GB |
174 | ((pred (car l)) (car l)) |
175 | (else (find-if pred (cdr l))))) | |
a6401ee0 | 176 | |
1a179b03 | 177 | (define (member-if pred l) |
abf94ef3 | 178 | "Return the first sublist of L for whose car PRED is true." |
a6401ee0 | 179 | (cond ((null? l) #f) |
16693054 GB |
180 | ((pred (car l)) l) |
181 | (else (member-if pred (cdr l))))) | |
a6401ee0 | 182 | |
1a179b03 | 183 | (define (remove-if pred l) |
c771038b TTN |
184 | "Remove all elements from L where (PRED element) is true. |
185 | Return everything that's left." | |
e5d2c2fa DH |
186 | (let loop ((l l) (result '())) |
187 | (cond ((null? l) (reverse! result)) | |
45cf8cd6 | 188 | ((pred (car l)) (loop (cdr l) result)) |
e5d2c2fa | 189 | (else (loop (cdr l) (cons (car l) result)))))) |
a6401ee0 | 190 | |
1a179b03 | 191 | (define (remove-if-not pred l) |
c771038b TTN |
192 | "Remove all elements from L where (PRED element) is #f. |
193 | Return everything that's left." | |
e5d2c2fa DH |
194 | (let loop ((l l) (result '())) |
195 | (cond ((null? l) (reverse! result)) | |
45cf8cd6 | 196 | ((not (pred (car l))) (loop (cdr l) result)) |
e5d2c2fa | 197 | (else (loop (cdr l) (cons (car l) result)))))) |
16693054 | 198 | |
1a179b03 | 199 | (define (delete-if! pred l) |
16693054 | 200 | "Destructive version of `remove-if'." |
e5d2c2fa DH |
201 | (let delete-if ((l l)) |
202 | (cond ((null? l) '()) | |
203 | ((pred (car l)) (delete-if (cdr l))) | |
a6401ee0 | 204 | (else |
e5d2c2fa | 205 | (set-cdr! l (delete-if (cdr l))) |
c771038b | 206 | l)))) |
a6401ee0 | 207 | |
1a179b03 | 208 | (define (delete-if-not! pred l) |
16693054 | 209 | "Destructive version of `remove-if-not'." |
e5d2c2fa DH |
210 | (let delete-if-not ((l l)) |
211 | (cond ((null? l) '()) | |
212 | ((not (pred (car l))) (delete-if-not (cdr l))) | |
a6401ee0 | 213 | (else |
e5d2c2fa DH |
214 | (set-cdr! l (delete-if-not (cdr l))) |
215 | l)))) | |
a6401ee0 | 216 | |
1a179b03 | 217 | (define (butlast lst n) |
16693054 | 218 | "Return all but the last N elements of LST." |
a6401ee0 JB |
219 | (letrec ((l (- (length lst) n)) |
220 | (bl (lambda (lst n) | |
221 | (cond ((null? lst) lst) | |
222 | ((positive? n) | |
223 | (cons (car lst) (bl (cdr lst) (+ -1 n)))) | |
224 | (else '()))))) | |
225 | (bl lst (if (negative? n) | |
226 | (error "negative argument to butlast" n) | |
227 | l)))) | |
228 | ||
1a179b03 | 229 | (define (and? . args) |
59dd1852 | 230 | "Return #t iff all of ARGS are true." |
a6401ee0 JB |
231 | (cond ((null? args) #t) |
232 | ((car args) (apply and? (cdr args))) | |
233 | (else #f))) | |
234 | ||
1a179b03 | 235 | (define (or? . args) |
59dd1852 | 236 | "Return #t iff any of ARGS is true." |
a6401ee0 JB |
237 | (cond ((null? args) #f) |
238 | ((car args) #t) | |
239 | (else (apply or? (cdr args))))) | |
240 | ||
1a179b03 | 241 | (define (has-duplicates? lst) |
16693054 | 242 | "Return #t iff 2 members of LST are equal?, else #f." |
a6401ee0 JB |
243 | (cond ((null? lst) #f) |
244 | ((member (car lst) (cdr lst)) #t) | |
245 | (else (has-duplicates? (cdr lst))))) | |
246 | ||
1a179b03 | 247 | (define (pick p l) |
16693054 GB |
248 | "Apply P to each element of L, returning a list of elts |
249 | for which P returns a non-#f value." | |
a6401ee0 JB |
250 | (let loop ((s '()) |
251 | (l l)) | |
252 | (cond | |
253 | ((null? l) s) | |
254 | ((p (car l)) (loop (cons (car l) s) (cdr l))) | |
255 | (else (loop s (cdr l)))))) | |
256 | ||
1a179b03 | 257 | (define (pick-mappings p l) |
c771038b | 258 | "Apply P to each element of L, returning a list of the |
16693054 | 259 | non-#f return values of P." |
a6401ee0 JB |
260 | (let loop ((s '()) |
261 | (l l)) | |
262 | (cond | |
263 | ((null? l) s) | |
264 | ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) | |
265 | (else (loop s (cdr l)))))) | |
266 | ||
1a179b03 | 267 | (define (uniq l) |
16693054 | 268 | "Return a list containing elements of L, with duplicates removed." |
23d91908 MV |
269 | (let loop ((acc '()) |
270 | (l l)) | |
271 | (if (null? l) | |
272 | (reverse! acc) | |
273 | (loop (if (memq (car l) acc) | |
274 | acc | |
275 | (cons (car l) acc)) | |
276 | (cdr l))))) | |
c771038b TTN |
277 | |
278 | ;;; common-list.scm ends here |