Added `count'.

svn: r14210

collects/scheme/list.ss

@@ -20,11 +20,12 @@
          add-between
          remove-duplicates
          filter-map
+         count
          partition
 
          argmin
          argmax
-         
+
          ;; convenience
          append-map
          filter-not)
@@ -237,6 +238,27 @@
         (let ([x (f (car l))])
           (if x (cons x (loop (cdr l))) (loop (cdr l))))))))
 
+;; very similar to `filter-map', one more such function will justify some macro
+(define (count f l . ls)
+  (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
+    (raise-type-error
+     'count (format "procedure (arity ~a)" (add1 (length ls))) f))
+  (unless (and (list? l) (andmap list? ls))
+    (raise-type-error
+     'count "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] [c 0])
+          (if (null? l)
+            c
+            (loop (cdr l) (map cdr ls)
+                  (if (apply f (car l) (map car ls)) (add1 c) c))))
+        (error 'count "all lists must have same size")))
+    (let loop ([l l] [c 0])
+      (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c))))))
+
 ;; 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))

collects/scribblings/reference/pairs.scrbl

@@ -633,6 +633,13 @@ Returns @scheme[(filter (lambda (x) x) (map proc lst ...))], but
 without building the intermediate list.}
 
 
+@defproc[(count [proc procedure?] [lst list?] ...+)
+         list?]{
+
+Returns @scheme[(length (filter proc lst ...))], but
+without building the intermediate list.}
+
+
 @defproc[(partition [pred procedure?] [lst list?])
          (values list? list?)]{
 

collects/tests/mzscheme/list.ss

@@ -263,6 +263,15 @@
   (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)))
 
+;; ---------- count ----------
+
+(let ()
+  (test 0 count even? '())
+  (test 4 count even? '(0 2 4 6))
+  (test 0 count even? '(1 3 5 7))
+  (test 2 count even? '(1 2 3 4))
+  (test 2 count < '(1 2 3 4) '(4 3 2 1)))
+
 ;; ---------- append-map ----------
 (let ()
   (define am append-map)
@@ -273,53 +282,53 @@
 ;; ---------- argmin & argmax ----------
 
 (let ()
-  
+
   (define ((check-regs . regexps) exn)
     (and (exn:fail? exn)
          (andmap (λ (reg) (regexp-match reg (exn-message exn)))
                  regexps)))
-  
+
   (test 'argmin object-name argmin)
   (test 1 argmin (lambda (x) 0) (list 1))
   (test 1 argmin (lambda (x) x) (list 1 2 3))
   (test 1 argmin (lambda (x) 1) (list 1 2 3))
-  
+
   (test 3
         'argmin-makes-right-number-of-calls
         (let ([c 0])
           (argmin (lambda (x) (set! c (+ c 1)) 0)
                   (list 1 2 3))
           c))
-  
+
   (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples)))
-  
+
   (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure"))
   (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list"))
   (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
   (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
-  
+
   (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers"))
   (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list"))
-  
+
   (test 'argmax object-name argmax)
   (test 1 argmax (lambda (x) 0) (list 1))
   (test 3 argmax (lambda (x) x) (list 1 2 3))
   (test 1 argmax (lambda (x) 1) (list 1 2 3))
-  
+
   (test 3
         'argmax-makes-right-number-of-calls
         (let ([c 0])
           (argmax (lambda (x) (set! c (+ c 1)) 0)
                   (list 1 2 3))
           c))
-  
+
   (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples)))
-  
+
   (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure"))
   (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list"))
   (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
   (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
-  
+
   (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers"))
   (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list")))