Added append-map' and filter-not'.

svn: r9433

collects/scheme/list.ss

@@ -16,7 +16,11 @@
          add-between
          remove-duplicates
          filter-map
-         partition)
+         partition
+
+         ;; convenience
+         append-map
+         filter-not)
 
 (define (first x)
   (if (and (pair? x) (list? x))
@@ -200,3 +204,23 @@
       (values (reverse i) (reverse o))
       (let ([x (car l)] [l (cdr l)])
         (if (pred x) (loop l (cons x i) o) (loop l i (cons x o)))))))
+
+(define append-map
+  (case-lambda [(f l) (apply append (map f l))]
+               [(f l1 l2) (apply append (map f l1 l2))]
+               [(f l . ls) (apply append (apply map f l ls))]))
+
+;; this is an exact copy of `filter' in scheme/private/list, with the
+;; `if' branches swapped.
+(define (filter-not f list)
+  (unless (and (procedure? f)
+               (procedure-arity-includes? f 1))
+    (raise-type-error 'filter-not "procedure (arity 1)" f))
+  (unless (list? list)
+    (raise-type-error 'filter-not "proper list" list))
+  ;; accumulating the result and reversing it is currently slightly
+  ;; faster than a plain loop
+  (let loop ([l list] [result null])
+    (if (null? l)
+      (reverse result)
+      (loop (cdr l) (if (f (car l)) result (cons (car l) result))))))

collects/scribblings/reference/pairs.scrbl

@@ -612,6 +612,21 @@ but @scheme[pred] is applied to each item in @scheme[lst] only once.
   (partition even? '(1 2 3 4 5 6))
 ]}
 
+@defproc[(append-map [proc (any/c . -> . list?)] [lst list?] ...+)
+         list?]{
+Like @scheme[map], but the resulting lists are appended together.
+This is the same as @scheme[(append* (map proc lst ...))].}
+
+@defproc[(filter-not [proc (any/c . -> . list?)] [lst list?] ...+)
+         list?]{
+Like @scheme[map], but the resulting lists are appended together.
+This is the same as @scheme[(append* (map proc lst ...))].}
+@defproc[(filter-not [proc procedure?] [lst list?])
+         list?]{
+Like @scheme[filter], but the meaning of the @scheme[proc] predicate
+is reversed: the result is a list of all items for which it returns
+@scheme[#f].}
+
 @; ----------------------------------------
 @section{Immutable Cyclic Data}
 

collects/tests/mzscheme/list.ss

@@ -21,13 +21,6 @@
 (arity-test foldl 3 -1)
 (arity-test foldr 3 -1)
 
-(test '(1 2 3) filter number? '(1 a 2 b 3 c d))
-(test '() filter string? '(1 a 2 b 3 c d))
-(err/rt-test (filter string? '(1 2 3 . 4)) exn:application:mismatch?)
-(err/rt-test (filter 2 '(1 2 3)))
-(err/rt-test (filter cons '(1 2 3)))
-(arity-test filter 2 2)
-
 (test '(0 1 2) memf add1 '(0 1 2))
 (test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
 (test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))
@@ -227,14 +220,25 @@
     (test long rd (append long (reverse long))) ; keeps first
     (test long rd (append* (map (lambda (x) (list x x)) long)))))
 
-;; ---------- filter-map ----------
+;; ---------- filter and filter-not ----------
 (let ()
-  (define fm filter-map)
+  (define f filter)
-  (test '() fm values '())
+  (define fn filter-not)
-  (test '(1 2 3) fm values '(1 2 3))
+
-  (test '() fm values '(#f #f #f))
+  (test '()              f  number? '())
-  (test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f))
+  (test '()              fn number? '())
-  (test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6)))
+  (test '(1 2 3)         f  number? '(1 a 2 b 3 c d))
+  (test '(a b c d)       fn number? '(1 a 2 b 3 c d))
+  (test '()              f  string? '(1 a 2 b 3 c d))
+  (test '(1 a 2 b 3 c d) fn string? '(1 a 2 b 3 c d))
+  (err/rt-test (f string? '(1 2 3 . 4)) exn:application:mismatch?)
+  (err/rt-test (fn string? '(1 2 3 . 4)) exn:application:mismatch?)
+  (err/rt-test (f  2 '(1 2 3)))
+  (err/rt-test (fn 2 '(1 2 3)))
+  (err/rt-test (f cons '(1 2 3)))
+  (err/rt-test (fn cons '(1 2 3)))
+  (arity-test f  2 2)
+  (arity-test fn 2 2))
 
 ;; ---------- partition ----------
 (let ()
@@ -246,6 +250,22 @@
   (test '((2 4) (1 3)) p even? '(1 2 3 4))
   (test '((1 3) (2 4)) p odd? '(1 2 3 4)))
 
+;; ---------- filter-map ----------
+(let ()
+  (define fm filter-map)
+  (test '() fm values '())
+  (test '(1 2 3) fm values '(1 2 3))
+  (test '() fm values '(#f #f #f))
+  (test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f))
+  (test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6)))
+
+;; ---------- append-map ----------
+(let ()
+  (define am append-map)
+  (test '() am list '())
+  (test '(1 2 3) am list '(1 2 3))
+  (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3)))
+
 ;; ---------- check no collisions with srfi/1 ----------
 (test (void)
       eval '(module foo scheme/base (require scheme/base srfi/1/list))