From b1024c895297e725194a04c93a97476289b6ff07 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 23 Apr 2008 17:26:41 +0000 Subject: [PATCH] Added `append-map' and `filter-not'. svn: r9433 --- collects/scheme/list.ss | 26 +++++++++++- collects/scribblings/reference/pairs.scrbl | 15 +++++++ collects/tests/mzscheme/list.ss | 48 +++++++++++++++------- 3 files changed, 74 insertions(+), 15 deletions(-) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index 714af32038..3452f54316 100644 --- a/collects/scheme/list.ss +++ b/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)))))) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 9d5ee48d34..580824ddd2 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/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} diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 1282fc152c..d7d81e7406 100644 --- a/collects/tests/mzscheme/list.ss +++ b/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) - (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))) + (define f filter) + (define fn filter-not) + + (test '() f number? '()) + (test '() fn number? '()) + (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))