Changes ready for second draft

Bug fixes; remove explicit type-test argument to
make-product-comparator; remove dependency on generators; add examples.

1 files changed, 54 insertions, 44 deletions

diff --git a/composing-comparators.scm b/composing-comparators.scm
index 89678d0..d121698 100644
--- a/composing-comparators.scm
+++ b/composing-comparators.scm
@@ -16,57 +16,65 @@
         ((comparator-hash-function contents-comparator) x))
       #f)))
 
-(define (make-product-comparator type-test . comparators)
-  (make-comparator
-   type-test
-   (if (every comparator-equality-predicate comparators)
-       (lambda (a b)
-         (every (lambda (cmp)
-                  ((comparator-equality-predicate cmp) a b))
-                comparators))
-       #f)
-   (if (every comparator-ordering-predicate comparators)
-       (lambda (a b)
-         (let ((gen (list->generator comparators)))
-           (let loop ((cmp (gen)))
-             (cond ((eof-object? cmp) #f)
-                   (((comparator-ordering-predicate cmp) a b) #t)
-                   (((comparator-equality-predicate cmp) a b) (loop (gen)))
-                   (else #f)))))
-       #f)
-   (if (every comparator-hash-function comparators)
-       (lambda (x)
-         (generator-fold bitwise-xor
-                         0
-                         (gmap (lambda (cmp)
-                                 ((comparator-hash-function cmp) x))
-                               (list->generator comparators))))
-       #f)))
+(define (make-product-comparator . comparators)
+  (let* ((type-tests
+          (delete-duplicates
+           (map comparator-type-test-predicate comparators)
+           eq?))
+         (type-test
+          (lambda (val)
+            (every (lambda (test) (test val)) type-tests))))
+    (make-comparator
+     type-test
+     (if (every comparator-equality-predicate comparators)
+         (lambda (a b)
+           (every (lambda (cmp)
+                    ((comparator-equality-predicate cmp) a b))
+                  comparators))
+         #f)
+     (if (every comparator-ordering-predicate comparators)
+         (lambda (a b)
+           (let loop ((cmps comparators))
+             (cond ((null? cmps) #f)
+                   (((comparator-ordering-predicate (car cmps)) a b) #t)
+                   (((comparator-equality-predicate (car cmps)) a b) (loop (cdr cmps)))
+                   (else #f))))
+         #f)
+     (if (every comparator-hash-function comparators)
+         (lambda (x)
+           (fold bitwise-xor
+                 0
+                 (map (lambda (cmp)
+                        ((comparator-hash-function cmp) x))
+                      comparators)))
+         #f))))
+
+(define (comparator-index comparators val)
+  (list-index
+   (lambda (cmp)
+     ((comparator-type-test-predicate cmp) val))
+   comparators))
 
 (define (make-sum-comparator . comparators)
   (make-comparator
    (lambda (x)
-     (any (lambda (cmp) ((comparator-type-test cmp) x)) comparators))
+     (any
+      (lambda (cmp)
+        ((comparator-type-test-predicate cmp) x))
+      comparators))
    (if (every comparator-equality-predicate comparators)
        (lambda (a b)
-         (let ((a-cmp-idx (list-index
-                           (lambda (cmp) ((comparator-type-test cmp) a))
-                           comparators))
-               (b-cmp-idx (list-index
-                           (lambda (cmp) ((comparator-type-test cmp) b))
-                           comparators))))
-         (if (not (= a-cmp-idx b-cmp-idx) #f)
-             (let ((cmp (list-ref comparators a-cmp-idx)))
-               ((comparator-equality-predicate cmp) a b))))
+         (let ((a-cmp-idx (comparator-index comparators a))
+               (b-cmp-idx (comparator-index comparators b)))
+           (if (not (= a-cmp-idx b-cmp-idx))
+               #f
+               (let ((cmp (list-ref comparators a-cmp-idx)))
+                 ((comparator-equality-predicate cmp) a b)))))
        #f)
    (if (every comparator-ordering-predicate comparators)
        (lambda (a b)
-         (let ((a-cmp-idx (list-index
-                           (lambda (cmp) ((comparator-type-test cmp) a))
-                           comparators))
-               (b-cmp-idx (list-index
-                           (lambda (cmp) ((comparator-type-test cmp) b))
-                           comparators)))
+         (let ((a-cmp-idx (comparator-index comparators a))
+               (b-cmp-idx (comparator-index comparators b)))
            (cond ((< a-cmp-idx b-cmp-idx) #t)
                  ((> a-cmp-idx b-cmp-idx) #f)
                  (else
@@ -75,8 +83,10 @@
        #f)
    (if (every comparator-hash-function comparators)
        (lambda (x)
-         (let ((cmp (find (lambda (cmp) ((comparator-type-test cmp) x)) comparators)))
-           ((comparator-hash-function cmp) x))))))
+         (let ((cmp (find (lambda (cmp) ((comparator-type-test-predicate cmp) x))
+                          comparators)))
+           ((comparator-hash-function cmp) x)))
+       #f)))
 
 (define (comparison-procedures comparator)
   (values