Move to "srfi/" directory. Follow naming convention.

1 files changed, 93 insertions, 0 deletions

diff --git a/srfi/srfi-228.scm b/srfi/srfi-228.scm
new file mode 100644
index 0000000..1591fbc
--- /dev/null
+++ b/srfi/srfi-228.scm
@@ -0,0 +1,93 @@
+(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 (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-predicate cmp) x))
+      comparators))
+   (lambda (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)))))
+   (if (every comparator-ordered? comparators)
+       (lambda (a b)
+         (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
+                  (let ((cmp (list-ref comparators a-cmp-idx)))
+                    ((comparator-ordering-predicate cmp) a b))))))
+       #f)
+   (if (every comparator-hashable? comparators)
+       (lambda (x)
+         (let ((cmp (find (lambda (cmp) ((comparator-type-test-predicate cmp) x))
+                          comparators)))
+           ((comparator-hash-function cmp) x)))
+       #f)))
+
+(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))))