Specify base cases and behaviours of each comparator function

2 files changed, 97 insertions, 0 deletions

diff --git a/srfi/228.sld b/srfi/228.sld
new file mode 100644
index 0000000..b3cca89
--- /dev/null
+++ b/srfi/228.sld
@@ -0,0 +1,10 @@
+(define-library (srfi 228)
+  (import (scheme base)
+          (srfi 1)
+          (srfi 128)
+          (srfi 151))
+  (export make-wrapper-comparator
+          make-product-comparator
+          make-sum-comparator)
+
+  (include "composing-comparators.scm"))
diff --git a/srfi/composing-comparators.scm b/srfi/composing-comparators.scm
new file mode 100644
index 0000000..3a93ae4
--- /dev/null
+++ b/srfi/composing-comparators.scm
@@ -0,0 +1,87 @@
+(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 . 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
+     (lambda (a b)
+       (every (lambda (cmp)
+                ((comparator-equality-predicate cmp) a b))
+              comparators))
+     (if (every comparator-ordered? 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-hashable? comparators)
+         (lambda (x)
+           (fold bitwise-xor
+                 0
+                 (map (lambda (cmp)
+                        ((comparator-hash-function cmp) x))
+                      comparators)))
+         #f))))
+
+(define (%sum-comparator-for comparators a b)
+  (define (type-tests-for? x)
+    (lambda (cmp) ((comparator-type-test-predicate cmp) x)))
+  (let ((a-cmp (find-tail (type-tests-for? a) comparators)))
+    (if (and a-cmp ((comparator-type-test-predicate (car a-cmp)) b))
+        a-cmp
+        (let ((b-cmp (find-tail (type-tests-for? a) comparators)))
+          (if (and b-cmp ((comparator-type-test-predicate (car b-cmp)) a))
+              b-cmp
+              #f)))))
+
+(define (make-sum-comparator . comparators)
+  (make-comparator
+   (lambda (x)
+     (any
+      (lambda (cmp)
+        ((comparator-type-test-predicate cmp) x))
+      comparators))
+   (lambda (a b)
+     (let ((cmp (%sum-comparator-for comparators a b)))
+       (if cmp
+           ((comparator-equality-predicate (car cmp)) a b)
+           #f)))
+   (if (every comparator-ordered? comparators)
+       (lambda (a b)
+         (let ((cmp (%sum-comparator-for comparators a b)))
+           (if cmp
+               ((comparator-ordering-predicate (car cmp)) a b)
+               (let ((a-cmp (%sum-comparator-for comparators a a))
+                     (b-cmp (%sum-comparator-for comparators b b)))
+                 (>= (length a-cmp) (length b-cmp))))))
+       #f)
+   (if (every comparator-hashable? comparators)
+       (lambda (x)
+         (let ((cmp (%sum-comparator-for comparators x x)))
+           ((comparator-hash-function (car cmp)) x)))
+       #f)))
+