From d4527d23dc4ce2c3af3e41144bf0bc2d595700a0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Marc=20Nieper-Wi=C3=9Fkirchen?= <marc@nieper-wisskirchen.de>
Date: Sat, 2 May 2020 21:05:19 +0200
Subject: [PATCH] Implement SRFI 162.

---
 lib/srfi/125/test.sld     |  7 ---
 lib/srfi/128.sld          | 14 +++++-
 lib/srfi/128/162-impl.scm | 93 +++++++++++++++++++++++++++++++++++++++
 lib/srfi/128/test.sld     | 26 ++++++++---
 4 files changed, 124 insertions(+), 16 deletions(-)
 create mode 100644 lib/srfi/128/162-impl.scm

diff --git a/lib/srfi/125/test.sld b/lib/srfi/125/test.sld
index 3265f243..6cba1d2e 100644
--- a/lib/srfi/125/test.sld
+++ b/lib/srfi/125/test.sld
@@ -5,15 +5,8 @@
           (chibi test))
   (begin
     (define (run-tests)
-      (define default-comparator (make-default-comparator))
       (define number-comparator
         (make-comparator real? = < (lambda (x . o) (exact (abs (round x))))))
-      (define string-comparator
-        (make-comparator string? string=? string<? string-hash))
-      (define string-ci-comparator
-        (make-comparator string? string-ci=? string-ci<? string-ci-hash))
-      (define eq-comparator (make-eq-comparator))
-      (define eqv-comparator (make-eqv-comparator))
       (define ht-default (make-hash-table default-comparator))
       (define ht-eq (make-hash-table eq-comparator 'random-argument "another"))
       (define ht-eqv (make-hash-table eqv-comparator))
diff --git a/lib/srfi/128.sld b/lib/srfi/128.sld
index 1d5aa903..9e45acb6 100644
--- a/lib/srfi/128.sld
+++ b/lib/srfi/128.sld
@@ -24,5 +24,15 @@
    ;; Comparison predicates:
    =? <? >? <=? >=?
    ;;Syntax:
-   comparator-if<=>)
-  (include "128/comparators.scm"))
+   comparator-if<=>
+   ;;SRFI 162:
+   comparator-max comparator-min
+   comparator-max-in-list comparator-min-in-list
+   default-comparator boolean-comparator real-comparator
+   char-comparator char-ci-comparator
+   string-comparator string-ci-comparator
+   list-comparator vector-comparator
+   eq-comparator eqv-comparator equal-comparator)
+  (include "128/comparators.scm")
+  (include "128/162-impl.scm")
+  )
diff --git a/lib/srfi/128/162-impl.scm b/lib/srfi/128/162-impl.scm
new file mode 100644
index 00000000..5244eaae
--- /dev/null
+++ b/lib/srfi/128/162-impl.scm
@@ -0,0 +1,93 @@
+(define (comparator-max-in-list comp list)
+  (let ((< (comparator-ordering-predicate comp)))
+    (let loop ((max (car list)) (list (cdr list)))
+      (if (null? list)
+        max
+        (if (< max (car list))
+          (loop (car list) (cdr list))
+          (loop max (cdr list)))))))
+
+(define (comparator-min-in-list comp list)
+  (let ((< (comparator-ordering-predicate comp)))
+    (let loop ((min (car list)) (list (cdr list)))
+      (if (null? list)
+        min
+        (if (< min (car list))
+          (loop min (cdr list))
+          (loop (car list) (cdr list)))))))
+
+(define (comparator-max comp . args)
+  (comparator-max-in-list comp args))
+
+(define (comparator-min comp . args)
+  (comparator-min-in-list comp args))
+
+#;
+(define default-comparator		;Defined in comparators.scm
+  (make-default-comparator))
+
+(define boolean-comparator
+  (make-comparator
+    boolean?
+    boolean=?
+    (lambda (x y) (and (not x) y))
+    boolean-hash))
+
+(define real-comparator
+  (make-comparator
+    real?
+    =
+    <
+    number-hash))
+
+(define char-comparator
+  (make-comparator
+    char?
+    char=?
+    char<?
+    (lambda (c) (number-hash (char->integer c)))))
+
+(define char-ci-comparator
+  (make-comparator
+    char?
+    char-ci=?
+    char-ci<?
+    (lambda (c) (number-hash (char->integer (char-downcase c))))))
+
+(define string-comparator
+  (make-comparator
+    string?
+    string=?
+    string<?
+    string-hash))
+
+(define string-ci-comparator
+  (make-comparator
+    string?
+    string-ci=?
+    string-ci<?
+    string-ci-hash))
+
+(define pair-comparator
+  (make-pair-comparator
+    default-comparator
+    default-comparator))
+
+(define list-comparator
+  (make-list-comparator
+    default-comparator
+    list?
+    null?
+    car
+    cdr))
+
+(define vector-comparator
+  (make-vector-comparator
+    default-comparator
+    vector?
+    vector-length
+    vector-ref))
+
+(define eq-comparator (make-eq-comparator))
+(define eqv-comparator (make-eqv-comparator))
+(define equal-comparator (make-equal-comparator))
diff --git a/lib/srfi/128/test.sld b/lib/srfi/128/test.sld
index 07f61d25..a69345bd 100644
--- a/lib/srfi/128/test.sld
+++ b/lib/srfi/128/test.sld
@@ -2,11 +2,7 @@
   (export run-tests)
   (import (scheme base) (srfi 128) (chibi test))
   (begin
-    (define default-comparator (make-default-comparator))
-    (define real-comparator (make-comparator real? = < number-hash))
     (define degenerate-comparator (make-comparator (lambda (x) #t) equal? #f #f))
-    (define boolean-comparator
-      (make-comparator boolean? eq? (lambda (x y) (and (not x) y)) boolean-hash))
     (define bool-pair-comparator
       (make-pair-comparator boolean-comparator boolean-comparator))
     (define num-list-comparator
@@ -30,9 +26,6 @@
        vector-cdr))
     (define list-qua-vector-comparator
       (make-vector-comparator default-comparator list? length list-ref))
-    (define eq-comparator (make-eq-comparator))
-    (define eqv-comparator (make-eqv-comparator))
-    (define equal-comparator (make-equal-comparator))
     (define symbol-comparator
       (make-comparator
        symbol?
@@ -280,4 +273,23 @@
           #;  (test (hash-salt) (fake-salt-hash #t))  ; no such thing as fake-salt-hash
           )                              ; end comparators/bound-salt
 
+
+	(test-group "comparators/min-max"
+	  (test 5 (comparator-max real-comparator 1 5 3 2 -2))
+	  (test -2 (comparator-min real-comparator 1 5 3 2 -2))
+	  (test 5 (comparator-max-in-list real-comparator '(1 5 3 2 -2)))
+	  (test -2 (comparator-min-in-list real-comparator '(1 5 3 2 -2)))
+	  ) ; end comparators/min-max
+
+	(test-group "comparators/variables"
+	  ;; Most of the variables have been tested above.
+	  (test-assert (=? char-comparator #\C #\C))
+	  (test-assert (=? char-ci-comparator #\c #\C))
+	  (test-assert (=? string-comparator "ABC" "ABC"))
+	  (test-assert (=? string-ci-comparator "abc" "ABC"))
+	  (test-assert (=? eq-comparator 32 32))
+	  (test-assert (=? eqv-comparator 32 32))
+	  (test-assert (=? equal-comparator "ABC" "ABC"))
+	  ) ; end comparators/variables
+
         ))))                             ; end comparators