(define (make-wrapper-comparator type-test unwrap contents-comparator)
  (make-comparator
   type-test
   (lambda (a b)
     ((comparator-equality-predicate contents-comparator)
      (unwrap a)
      (unwrap b)))
   (if (comparator-ordering-predicate contents-comparator)
       (lambda (a b)
         ((comparator-ordering-predicate contents-comparator)
          (unwrap a)
          (unwrap b)))
       #f)
  (if (comparator-hash-function contents-comparator)
      (lambda (x)
        ((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-sum-comparator . comparators)
  (make-comparator
   (lambda (x)
     (any (lambda (cmp) ((comparator-type-test 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))))
       #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)))
           (cond ((< a-cmp-idx b-cmp-idx) #t)
                 ((> a-cmp-idx b-cmp-idx) #f)
                 (else
                  (let ((cmp (list-ref comparators a-cmp-idx)))
                    ((comparator-ordering-predicate cmp) a b))))))
       #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))))))

(define (comparison-procedures comparator)
  (values
   (lambda args (apply <? comparator args))
   (lambda args (apply <=? comparator args))
   (lambda args (apply =? comparator args))
   (lambda args (apply >=? comparator args))
   (lambda args (apply >? comparator args))))