Merge pull request #1 from dpk/master

Second draft

3 files changed, 149 insertions, 76 deletions

diff --git a/228.sld b/228.sld
index fdfbec1..3417d76 100644
--- a/228.sld
+++ b/228.sld
@@ -1,11 +1,9 @@
 (define-library (srfi 228)
   (import (srfi 1)
-          (srfi 128)
-          (srfi 151)
-          (srfi 158))
+          (srfi 128))
   (export make-wrapper-comparator
-          make-composed-comparator
-          compose-comparator
+          make-product-comparator
+          make-sum-comparator
           comparison-procedures)
 
   (include "composing-comparators.scm"))
diff --git a/composing-comparators.scm b/composing-comparators.scm
index c6b6c7d..d121698 100644
--- a/composing-comparators.scm
+++ b/composing-comparators.scm
@@ -16,55 +16,78 @@
         ((comparator-hash-function contents-comparator) x))
       #f)))
 
-(define (make-composed-comparator type-test . comparators)
+(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
-   type-test
+   (lambda (x)
+     (any
+      (lambda (cmp)
+        ((comparator-type-test-predicate cmp) x))
+      comparators))
    (if (every comparator-equality-predicate comparators)
        (lambda (a b)
-         (every (lambda (cmp)
-                  ((comparator-equality-predicate cmp) a b))
-                comparators))
+         (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 ((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)))))
+         (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-hash-function comparators)
        (lambda (x)
-         (generator-fold bitwise-xor
-                         0
-                         (gmap (lambda (cmp)
-                                 ((comparator-hash-function cmp) x))
-                               (list->generator comparators))))
+         (let ((cmp (find (lambda (cmp) ((comparator-type-test-predicate cmp) x))
+                          comparators)))
+           ((comparator-hash-function cmp) x)))
        #f)))
 
-(define-syntax compose-comparator
-  (syntax-rules ()
-    ((_ type-test (unwrap . more) ...)
-     (make-composed-comparator
-      type-test
-      (let-values (((unwrap cmp) (compose-comparator-form unwrap . more)))
-        (make-wrapper-comparator
-         (comparator-type-test-predicate cmp)
-         unwrap
-         cmp)) ...))))
-
-(define-syntax compose-comparator-form
-  ;; Using this submacro enables enforcement of the correct form with
-  ;; moderately more useful syntax errors than doing it the SRFI 9
-  ;; way, at least within the limited bounds of what one can do for
-  ;; that in syntax-rules.
-  (syntax-rules ()
-    ((_ unwrap) (compose-comparator-form unwrap (make-default-comparator)))
-    ((_ unwrap cmp)
-     (values
-      unwrap cmp))))
-
 (define (comparison-procedures comparator)
   (values
    (lambda args (apply <? comparator args))
diff --git a/srfi-228.html b/srfi-228.html
index 3f37df9..3007772 100644
--- a/srfi-228.html
+++ b/srfi-228.html
@@ -48,17 +48,14 @@
   <dt><code>(make-wrapper-comparator</code> <var>type-test</var> <var>unwrap</var> <var>contents-comparator</var><code>)</code> (Procedure)
     <dd>
       <p>Returns a comparator which compares values satisfying the predicate <var>type-test</var> by first calling the given <var>unwrap</var> procedure on them, then comparing the output of that procedure with the given <var>contents-comparator</var>. The hash function of the wrapper comparator returns the same value as the <var>contents-comparator</var> run on the unwrapped value.</p>
-      <p class=issue>Add example.</p>
 
-  <dt><code>(make-wrapper-comparator</code> <var>type-test</var> <var>comparator</var> ... <code>)</code> (Procedure)
+  <dt><code>(make-product-comparator</code> <var>comparator</var> ... <code>)</code> (Procedure)
     <dd>
-      <p>Returns a comparator which compares values satisfying the given predicate <var>type-test</var> by comparing them with each of the given comparators in turn, left to right, and returning the result of the first non-equal comparison. If all the given comparators consider two values equal, the composed comparator also considers them equal. The hash function of the composed comparator hashes together the results of all the given comparators in an implementation-defined way.</p>
-      <p class=issue>Add example.</p>
+      <p>Returns a comparator which compares values satisfying the type tests of all of the given <var>comparator</var>s by comparing them with each of the given comparators in turn, left to right, and returning the result of the first non-equal comparison. If all the given comparators consider two values equal, the product comparator also considers them equal. The hash function of the product comparator hashes together the results of all the given comparators in an implementation-defined way. If the equality or ordering predicates or the hash function of any of the given comparators is <code>#f</code>, the corresponding procedure in the product comparator will also be <code>#f</code>.</p>
 
-  <dt><code>(compose-comparator</code> <var>type-test</var> <code>(</code><var>unwrap</var> <var>comparator</var><code>) ...)</code> (Syntax)
+  <dt><code>(make-sum-comparator</code> <var>comparator</var> ... <code>)</code> (Procedure)
     <dd>
-      <p>Expands to a form which returns a comparator which compares values satisfying the given predicate <code>type-test</code> by running in turn, left to right, wrapper comparators made out of the given <code>unwrap</code> and <code>comparator</code>, according to the rules for <code>make-composed-comparator</code>. <code>comparator</code> may be omitted from each form, in which case the SRFI 128 default comparator is used.</p>
-      <p>This is equivalent to using the procedural forms <code>make-composed-comparator</code> and <code>make-wrapper-comparator</code> together.</p>
+      <p>Returns a comparator which compares values satisfying the type-tests of any of the given comparators, such that values which satisfy the type-test of a given comparator are ordered before any values satisfying the type-tests of any comparators appear to the right of it, and values satisfying the same comparator’s type-test are tested for ordering and equality according that comparator. The hash function of the sum comparator returns the value of the hash function of the leftmost comparator whose type-test is satisfied by the given value. If the equality or ordering predicates or the hash function of any of the given comparators is <code>#f</code>, the corresponding procedure in the product comparator will also be <code>#f</code>.</p>
 
   <dt><code>(comparison-procedures</code> <var>comparator</var><code>)</code> (Procedure)
     <dd>
@@ -67,32 +64,81 @@
       <p class=issue>As long as we’re stuck with positional return values, I should note that this isn’t the order usually used for the specification of comparison procedures (e.g. the <code>char*?</code> family in R7RS small uses the order <code>char=?</code>, <code>char&lt;?</code>, <code>char&gt;?</code>. <code>char&lt;=?</code>, <code>char&gt;=?</code>). I find the order here easier to remember, but perhaps it would be better to switch to that order for consistency.</p>
 </dl>
 
-<p class=issue>I’d also like to provide a constructor for comparators which work on any iterable collection type (à la SRFI 158 generators). My initial plan was to use fold procedures for this, but that doesn’t actually work. Generator comparators seems like a better approach.</p>
-
 <h2 id=examples>Examples</h2>
 
-<p><code>make-pair-comparator</code> from SRFI 128 can be implemented in terms of this library as follows:</p>
-<pre><code class="language-scheme">(define (make-pair-comparator car-comparator cdr-comparator)
-  (compose-comparator pair? (car car-comparator) (cdr cdr-comparator)))
-</code></pre>
-<p>If one has defined a date record type consisting of year, month, and day fields such as:</p>
-<pre><code class="language-scheme">(define-record-type &lt;date&gt;
-  (make-date year month day)
-  date?
-  (year date-year)
-  (month date-month)
-  (day date-day))
-</code></pre>
-<p>these can be correctly compared by a comparator defined by:</p>
-<pre><code class="language-scheme">(compose-comparator date?
-  (date-year)  ;; Equivalent to (date-year (make-default-comparator))
-  (date-month)
-  (date-day))
-</code></pre>
-<p>And monomorphic comparison procedures matching those provided for Scheme’s built-in types can be defined by:</p>
-<pre><code class="language-scheme">(define-values (date&lt;? date&lt;=? date=? date&gt;=? date&gt;?)
-  (comparison-procedures the-date-comparator-above))
-</code></pre>
+<p>Personal names are usually sorted lexicographically and case-insensitively by the last name, then the first name if the last names are the same. The following example shows how <code>make-wrapper-comparator</code> and <code>make-product-comparator</code> can be used to create a comparator which orders a record type of personal names in this way, and how <code>comparison-procedures</code> can then be used for this ordering.
+
+<pre><code>(define-record-type Person
+  (make-person first-name last-name)
+  person?
+  (first-name person-first-name)
+  (last-name person-last-name))
+
+(define person-name-comparator
+  (make-product-comparator
+   (make-wrapper-comparator person? person-last-name string-ci-comparator)
+   (make-wrapper-comparator person? person-first-name string-ci-comparator)))
+
+(define-values (person-name&lt;?
+                person-name&lt;=?
+                person-name=?
+                person-name>?
+                person-name>=?)
+  (comparison-procedures person-name-comparator))
+
+(person-name&lt;? (make-person "John" "Cowan")
+               (make-person "Daphne" "Preston-Kendal")) ;=> #t
+
+(person-name>? (make-person "Tom" "Smith")
+               (make-person "John" "Smith")) ;=> #t</code></pre>
+
+<p>This example can be extended with nested comparators to sort a catalogue in which CDs appear at the end of the list after books:
+
+<pre><code>(define-record-type Book
+  (make-book author title)
+  book?
+  (author book-author)
+  (title book-title))
+
+(define book-comparator
+  (make-product-comparator
+   (make-wrapper-comparator book? book-author person-name-comparator)
+   (make-wrapper-comparator book? book-title string-ci-comparator)))
+
+(define-record-type CD
+  (make-cd artist title)
+  cd?
+  (artist cd-artist)
+  (title cd-title))
+
+(define cd-comparator
+  (make-product-comparator
+   (make-wrapper-comparator cd? cd-artist person-name-comparator)
+   (make-wrapper-comparator cd? cd-title string-ci-comparator)))
+
+(define item-comparator
+  (make-sum-comparator book-comparator cd-comparator))
+
+(define-values (item&lt;?
+                item&lt;=?
+                item=?
+                item>?
+                item>=?)
+  (comparison-procedures item-comparator))
+
+(list-sort item&lt;?
+           (list (make-cd (make-person "The" "Beatles") "Abbey Road")
+                 (make-book (make-person "Jacob" "Grimm") "Deutsche Grammatik")
+                 (make-book (make-person "William" "Shakespeare") "Sonnets")
+                 (make-book (make-person "William" "Shakespeare") "A Midsummer Night’s Dream")
+                 (make-cd (make-person "Bob" "Dylan") "Blonde on Blonde")
+                 (make-cd (make-person "The" "Beatles") "Revolver")))
+;; => ({Book {Person "Jacob" "Grimm"} "Deutsche Grammatik"}
+;;     {Book {Person "William" "Shakespeare"} "Sonnets"}
+;;     {Book {Person "William" "Shakespeare"} "A Midsummer Night’s Dream"}
+;;     {CD {Person "The" "Beatles"} "Abbey Road"}
+;;     {CD {Person "The" "Beatles"} "Revolver"}
+;;     {CD {Person "Bob" "Dylan"} "Blonde on Blonde"})</code></pre>
 
 <h2 id="implementation">Implementation</h2>
 
@@ -100,7 +146,13 @@
 
 <h2 id="acknowledgements">Acknowledgements</h2>
 
-<p class=issue>Thanks in advance to all who will contribute to this SRFI mailing list. I hope to list you by name with your contributions here when this SRFI approaches finalization.</p>
+<p><code>make-sum-comparator</code>, and by extension the inspiration for the name of <code>make-product-comparator</code>, is originally from Adam Nelson’s Schemepunk.
+
+<p>Marc Nieper-Wißkirchen and John Cowan suggested means of improving the <code>comparison-procedures</code> procedure; as of the current draft, this remains an open issue.
+
+<h2 id=future-work>Future work</h2>
+
+<p>The author hopes that a future SRFI will add a procedure for creating comparators yielding lexicographical order over any sequence type by delegating to a common iteration protocol. An idea to do this using <code>fold</code> procedures foundered on two grounds: the first and more intrinsic one is that <code>fold</code> called on two sequences, one of which is a prefix of the other, cannot determine which of the two is longer, and a sort using <code>fold</code>-based iteration would incorrectly consider them equal; the second is that there is currently an inconsistency among Scheme libraries in what order the <var>kons</var> procedure argument to <code>fold</code> receives the accumulator and the next values in the sequence (compare <a href="https://srfi.schemers.org/srfi-1/srfi-1.html#fold">SRFI 1 <code>fold</code></a> with <a href="https://srfi.schemers.org/srfi-133/srfi-133.html#vector-fold">SRFI 133 <code>vector-fold</code></a>). <a href="https://srfi.schemers.org/srfi-158/srfi-158.html">SRFI 158</a> generators were rejected on the ground that their sequences cannot contain any arbitrary Scheme datum.
 
 <h2 id="copyright">Copyright</h2>
 <p>&copy; 2021 Daphne Preston-Kendal.</p>
@@ -129,4 +181,4 @@
   SOFTWARE.</p>
 
 <hr>
-<address>Editor: <a href="mailto:srfi-editors+at+srfi+dot+schemers+dot+org">Arthur A. Gleckler</a></address></body></html>
\ No newline at end of file
+<address>Editor: <a href="mailto:srfi-editors+at+srfi+dot+schemers+dot+org">Arthur A. Gleckler</a></address></body></html>