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 | |
19 | ;;;; | |
20 | \f | |
a6401ee0 JB |
21 | (define-module (ice-9 common-list)) |
22 | ||
23 | ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme | |
24 | ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. | |
25 | ; | |
26 | ;Permission to copy this software, to redistribute it, and to use it | |
27 | ;for any purpose is granted, subject to the following restrictions and | |
28 | ;understandings. | |
29 | ; | |
30 | ;1. Any copy made of this software must include this copyright notice | |
31 | ;in full. | |
32 | ; | |
33 | ;2. I have made no warrantee or representation that the operation of | |
34 | ;this software will be error-free, and I am under no obligation to | |
35 | ;provide any services, by way of maintenance, update, or otherwise. | |
36 | ; | |
37 | ;3. In conjunction with products arising from the use of this | |
38 | ;material, there shall be no use of my name in any advertising, | |
39 | ;promotional, or sales literature without prior written consent in | |
40 | ;each case. | |
41 | ||
42 | (define-public (adjoin e l) (if (memq e l) l (cons e l))) | |
43 | ||
44 | (define-public (union l1 l2) | |
45 | (cond ((null? l1) l2) | |
46 | ((null? l2) l1) | |
47 | (else (union (cdr l1) (adjoin (car l1) l2))))) | |
48 | ||
49 | (define-public (intersection l1 l2) | |
50 | (cond ((null? l1) l1) | |
51 | ((null? l2) l2) | |
52 | ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) | |
53 | (else (intersection (cdr l1) l2)))) | |
54 | ||
55 | (define-public (set-difference l1 l2) | |
56 | (cond ((null? l1) l1) | |
57 | ((memv (car l1) l2) (set-difference (cdr l1) l2)) | |
58 | (else (cons (car l1) (set-difference (cdr l1) l2))))) | |
59 | ||
60 | (define-public (reduce-init p init l) | |
61 | (if (null? l) | |
62 | init | |
63 | (reduce-init p (p init (car l)) (cdr l)))) | |
64 | ||
65 | (define-public (reduce p l) | |
66 | (cond ((null? l) l) | |
67 | ((null? (cdr l)) (car l)) | |
68 | (else (reduce-init p (car l) (cdr l))))) | |
69 | ||
70 | (define-public (some pred l . rest) | |
71 | (cond ((null? rest) | |
72 | (let mapf ((l l)) | |
73 | (and (not (null? l)) | |
74 | (or (pred (car l)) (mapf (cdr l)))))) | |
75 | (else (let mapf ((l l) (rest rest)) | |
76 | (and (not (null? l)) | |
77 | (or (apply pred (car l) (map car rest)) | |
78 | (mapf (cdr l) (map cdr rest)))))))) | |
79 | ||
80 | (define-public (every pred l . rest) | |
81 | (cond ((null? rest) | |
82 | (let mapf ((l l)) | |
83 | (or (null? l) | |
84 | (and (pred (car l)) (mapf (cdr l)))))) | |
85 | (else (let mapf ((l l) (rest rest)) | |
86 | (or (null? l) | |
87 | (and (apply pred (car l) (map car rest)) | |
88 | (mapf (cdr l) (map cdr rest)))))))) | |
89 | ||
90 | (define-public (notany pred . ls) (not (apply some pred ls))) | |
91 | ||
92 | (define-public (notevery pred . ls) (not (apply every pred ls))) | |
93 | ||
94 | (define-public (find-if t l) | |
95 | (cond ((null? l) #f) | |
96 | ((t (car l)) (car l)) | |
97 | (else (find-if t (cdr l))))) | |
98 | ||
99 | (define-public (member-if t l) | |
100 | (cond ((null? l) #f) | |
101 | ((t (car l)) l) | |
102 | (else (member-if t (cdr l))))) | |
103 | ||
104 | (define-public (remove-if p l) | |
105 | (cond ((null? l) '()) | |
106 | ((p (car l)) (remove-if p (cdr l))) | |
107 | (else (cons (car l) (remove-if p (cdr l)))))) | |
108 | ||
109 | (define-public (delete-if! pred list) | |
110 | (let delete-if ((list list)) | |
111 | (cond ((null? list) '()) | |
112 | ((pred (car list)) (delete-if (cdr list))) | |
113 | (else | |
114 | (set-cdr! list (delete-if (cdr list))) | |
115 | list)))) | |
116 | ||
117 | (define-public (delete-if-not! pred list) | |
118 | (let delete-if ((list list)) | |
119 | (cond ((null? list) '()) | |
120 | ((not (pred (car list))) (delete-if (cdr list))) | |
121 | (else | |
122 | (set-cdr! list (delete-if (cdr list))) | |
123 | list)))) | |
124 | ||
125 | (define-public (butlast lst n) | |
126 | (letrec ((l (- (length lst) n)) | |
127 | (bl (lambda (lst n) | |
128 | (cond ((null? lst) lst) | |
129 | ((positive? n) | |
130 | (cons (car lst) (bl (cdr lst) (+ -1 n)))) | |
131 | (else '()))))) | |
132 | (bl lst (if (negative? n) | |
133 | (error "negative argument to butlast" n) | |
134 | l)))) | |
135 | ||
136 | (define-public (and? . args) | |
137 | (cond ((null? args) #t) | |
138 | ((car args) (apply and? (cdr args))) | |
139 | (else #f))) | |
140 | ||
141 | (define-public (or? . args) | |
142 | (cond ((null? args) #f) | |
143 | ((car args) #t) | |
144 | (else (apply or? (cdr args))))) | |
145 | ||
146 | (define-public (has-duplicates? lst) | |
147 | (cond ((null? lst) #f) | |
148 | ((member (car lst) (cdr lst)) #t) | |
149 | (else (has-duplicates? (cdr lst))))) | |
150 | ||
151 | (define-public (list* x . y) | |
152 | (define (list*1 x) | |
153 | (if (null? (cdr x)) | |
154 | (car x) | |
155 | (cons (car x) (list*1 (cdr x))))) | |
156 | (if (null? y) | |
157 | x | |
158 | (cons x (list*1 y)))) | |
159 | ||
160 | ;; pick p l | |
161 | ;; Apply P to each element of L, returning a list of elts | |
162 | ;; for which P returns a non-#f value. | |
163 | ;; | |
164 | (define-public (pick p l) | |
165 | (let loop ((s '()) | |
166 | (l l)) | |
167 | (cond | |
168 | ((null? l) s) | |
169 | ((p (car l)) (loop (cons (car l) s) (cdr l))) | |
170 | (else (loop s (cdr l)))))) | |
171 | ||
172 | ;; pick p l | |
173 | ;; Apply P to each element of L, returning a list of the | |
174 | ;; non-#f return values of P. | |
175 | ;; | |
176 | (define-public (pick-mappings p l) | |
177 | (let loop ((s '()) | |
178 | (l l)) | |
179 | (cond | |
180 | ((null? l) s) | |
181 | ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) | |
182 | (else (loop s (cdr l)))))) | |
183 | ||
184 | (define-public (uniq l) | |
185 | (if (null? l) | |
186 | '() | |
187 | (let ((u (uniq (cdr l)))) | |
188 | (if (memq (car l) u) | |
189 | u | |
190 | (cons (car l) u))))) | |
191 |