added filter-map' and partition', with tests

--This line, and those below, will be ignored--

M    collects/scheme/list.ss
M    collects/tests/mzscheme/list.ss

svn: r9421

collects/scheme/list.ss

@@ -15,7 +15,9 @@
          append*
          flatten
          add-between
-         remove-duplicates)
+         remove-duplicates
+         filter-map
+         partition)
 
 (define (first x)
   (if (and (pair? x) (list? x))
@@ -141,3 +143,53 @@
               [(eq? =? eqv?)   (loop memv)]
               [else (loop (lambda (x seen)
                             (ormap (lambda (y) (=? x y)) seen)))])))))
+
+(define (filter-map f l . ls)
+  (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
+    (raise-type-error
+     'filter-map (format "procedure (arity ~a)" (add1 (length ls))) f))
+  (unless (and (list? l) (andmap list? ls))
+    (raise-type-error
+     'filter-map "proper list"
+     (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
+  (if (pair? ls)
+    (let ([len (length l)])
+      (if (andmap (lambda (l) (= len (length l))) ls)
+        (let loop ([l l] [ls ls])
+          (if (null? l)
+            null
+            (let ([x (apply f (car l) (map car ls))])
+              (if x
+                (cons x (loop (cdr l) (map cdr ls)))
+                (loop (cdr l) (map cdr ls))))))
+        (error 'filter-map "all lists must have same size")))
+    (let loop ([l l])
+      (if (null? l)
+        null
+        (let ([x (f (car l))])
+          (if x (cons x (loop (cdr l))) (loop (cdr l))))))))
+
+;; Originally from srfi-1 -- shares common tail with the input when possible
+;; (define (partition f l)
+;;   (unless (and (procedure? f) (procedure-arity-includes? f 1))
+;;     (raise-type-error 'partition "procedure (arity 1)" f))
+;;   (unless (list? l) (raise-type-error 'partition "proper list" l))
+;;   (let loop ([l l])
+;;     (if (null? l)
+;;       (values null null)
+;;       (let* ([x (car l)] [x? (f x)])
+;;         (let-values ([(in out) (loop (cdr l))])
+;;           (if x?
+;;             (values (if (pair? out) (cons x in) l) out)
+;;             (values in (if (pair? in) (cons x out) l))))))))
+
+;; But that one is slower than this, probably due to value packages
+(define (partition pred l)
+  (unless (and (procedure? pred) (procedure-arity-includes? pred 1))
+    (raise-type-error 'partition "procedure (arity 1)" pred))
+  (unless (list? l) (raise-type-error 'partition "proper list" l))
+  (let loop ([l l] [i '()] [o '()])
+    (if (null? l)
+      (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)))))))

collects/tests/mzscheme/list.ss

@@ -216,6 +216,25 @@
     (test long rd (append long (reverse long))) ; keeps first
     (test long rd (append* (map (lambda (x) (list x x)) long)))))
 
+;; ---------- 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)))
+
+;; ---------- partition ----------
+(let ()
+  (define (p pred l) (call-with-values (lambda () (partition pred l)) list))
+  (test '(() ()) p (lambda (_) #t) '())
+  (test '(() ()) p (lambda (_) #f) '())
+  (test '((1 2 3 4) ()) p (lambda (_) #t) '(1 2 3 4))
+  (test '(() (1 2 3 4)) p (lambda (_) #f) '(1 2 3 4))
+  (test '((2 4) (1 3)) p even? '(1 2 3 4))
+  (test '((1 3) (2 4)) p odd? '(1 2 3 4)))
+
 ;; ---------- check no collisions with srfi/1 ----------
 (test (void)
       eval '(module foo scheme/base (require scheme/base srfi/1/list))