| 1 | ;;;; common-list.scm --- COMMON LISP list functions for Scheme |
| 2 | ;;;; |
| 3 | ;;;; Copyright (C) 1995, 1996, 1997, 2001, 2006 Free Software Foundation, Inc. |
| 4 | ;;;; |
| 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 |
| 8 | ;;;; version 2.1 of the License, or (at your option) any later version. |
| 9 | ;;;; |
| 10 | ;;;; This library 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 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 |
| 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
| 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: |
| 52 | \f |
| 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)) |
| 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 | |
| 78 | (define (adjoin e l) |
| 79 | "Return list L, possibly with element E added if it is not already in L." |
| 80 | (if (memq e l) l (cons e l))) |
| 81 | |
| 82 | (define (union l1 l2) |
| 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." |
| 86 | (cond ((null? l1) l2) |
| 87 | ((null? l2) l1) |
| 88 | (else (union (cdr l1) (adjoin (car l1) l2))))) |
| 89 | |
| 90 | (define (intersection l1 l2) |
| 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." |
| 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)))))) |
| 98 | |
| 99 | (define (set-difference l1 l2) |
| 100 | "Return elements from list L1 that are not in list L2." |
| 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)))))) |
| 105 | |
| 106 | (define (reduce-init p init l) |
| 107 | "Same as `reduce' except it implicitly inserts INIT at the start of L." |
| 108 | (if (null? l) |
| 109 | init |
| 110 | (reduce-init p (p init (car l)) (cdr l)))) |
| 111 | |
| 112 | (define (reduce p l) |
| 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 |
| 116 | accepts only two arguments to more than 2 objects. Functional |
| 117 | programmers usually refer to this as foldl." |
| 118 | (cond ((null? l) l) |
| 119 | ((null? (cdr l)) (car l)) |
| 120 | (else (reduce-init p (car l) (cdr l))))) |
| 121 | |
| 122 | (define (some pred l . rest) |
| 123 | "PRED is a boolean function of as many arguments as there are list |
| 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." |
| 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 | |
| 138 | (define (every pred l . rest) |
| 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." |
| 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 | |
| 151 | (define (notany pred . ls) |
| 152 | "Return #t iff every application of PRED to L, etc., returns #f. |
| 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." |
| 155 | (not (apply some pred ls))) |
| 156 | |
| 157 | (define (notevery pred . ls) |
| 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 | |
| 163 | (define (count-if pred l) |
| 164 | "Return the number of elements in L for which (PRED element) returns true." |
| 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 | |
| 170 | (define (find-if pred l) |
| 171 | "Search for the first element in L for which (PRED element) returns true. |
| 172 | If found, return that element, otherwise return #f." |
| 173 | (cond ((null? l) #f) |
| 174 | ((pred (car l)) (car l)) |
| 175 | (else (find-if pred (cdr l))))) |
| 176 | |
| 177 | (define (member-if pred l) |
| 178 | "Return the first sublist of L for whose car PRED is true." |
| 179 | (cond ((null? l) #f) |
| 180 | ((pred (car l)) l) |
| 181 | (else (member-if pred (cdr l))))) |
| 182 | |
| 183 | (define (remove-if pred l) |
| 184 | "Remove all elements from L where (PRED element) is true. |
| 185 | Return everything that's left." |
| 186 | (let loop ((l l) (result '())) |
| 187 | (cond ((null? l) (reverse! result)) |
| 188 | ((pred (car l)) (loop (cdr l) result)) |
| 189 | (else (loop (cdr l) (cons (car l) result)))))) |
| 190 | |
| 191 | (define (remove-if-not pred l) |
| 192 | "Remove all elements from L where (PRED element) is #f. |
| 193 | Return everything that's left." |
| 194 | (let loop ((l l) (result '())) |
| 195 | (cond ((null? l) (reverse! result)) |
| 196 | ((not (pred (car l))) (loop (cdr l) result)) |
| 197 | (else (loop (cdr l) (cons (car l) result)))))) |
| 198 | |
| 199 | (define (delete-if! pred l) |
| 200 | "Destructive version of `remove-if'." |
| 201 | (let delete-if ((l l)) |
| 202 | (cond ((null? l) '()) |
| 203 | ((pred (car l)) (delete-if (cdr l))) |
| 204 | (else |
| 205 | (set-cdr! l (delete-if (cdr l))) |
| 206 | l)))) |
| 207 | |
| 208 | (define (delete-if-not! pred l) |
| 209 | "Destructive version of `remove-if-not'." |
| 210 | (let delete-if-not ((l l)) |
| 211 | (cond ((null? l) '()) |
| 212 | ((not (pred (car l))) (delete-if-not (cdr l))) |
| 213 | (else |
| 214 | (set-cdr! l (delete-if-not (cdr l))) |
| 215 | l)))) |
| 216 | |
| 217 | (define (butlast lst n) |
| 218 | "Return all but the last N elements of LST." |
| 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 | |
| 229 | (define (and? . args) |
| 230 | "Return #t iff all of ARGS are true." |
| 231 | (cond ((null? args) #t) |
| 232 | ((car args) (apply and? (cdr args))) |
| 233 | (else #f))) |
| 234 | |
| 235 | (define (or? . args) |
| 236 | "Return #t iff any of ARGS is true." |
| 237 | (cond ((null? args) #f) |
| 238 | ((car args) #t) |
| 239 | (else (apply or? (cdr args))))) |
| 240 | |
| 241 | (define (has-duplicates? lst) |
| 242 | "Return #t iff 2 members of LST are equal?, else #f." |
| 243 | (cond ((null? lst) #f) |
| 244 | ((member (car lst) (cdr lst)) #t) |
| 245 | (else (has-duplicates? (cdr lst))))) |
| 246 | |
| 247 | (define (pick p l) |
| 248 | "Apply P to each element of L, returning a list of elts |
| 249 | for which P returns a non-#f value." |
| 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 | |
| 257 | (define (pick-mappings p l) |
| 258 | "Apply P to each element of L, returning a list of the |
| 259 | non-#f return values of P." |
| 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 | |
| 267 | (define (uniq l) |
| 268 | "Return a list containing elements of L, with duplicates removed." |
| 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))))) |
| 277 | |
| 278 | ;;; common-list.scm ends here |