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