2.38.8.8 Refining comparators

Function: make-refining-comparator comparator0 comparator …

Return a comparator that makes use of the comparators in the same way as make-selecting-comparator, except that its procedures can look past the first comparator whose type test predicate is satisfied.

If the comparison procedure of the first comparator returns zero: the next comparator whose type test predicate is satisfied is tried, then the next and so on, until one returns a non–zero value. If there are no more such comparators, then the comparison procedure returns zero.

The equality predicate is defined in the same way. If no type test predicate is satisfied, an error is signalled.

The hash function of the result returns a value computed using the last comparator in the given list for which the type test procedure returns true.

According to the SRFI: the hash function of the result returns a value which depends, in an implementation–defined way, on the results of invoking the hash functions of the comparators whose type test predicates are satisfied on its argument. In particular, it may depend solely on the first or last such hash function. If no type test predicate is satisfied, an error is signalled.

This procedure is analogous to the expression type refine-compare from SRFI-67.

#!vicare
(import (vicare) (srfi :114))

(define* (round-to-epsilon {R flonum?} {epsilon flonum?})
  (infix round(R / epsilon) * epsilon))

(define-constant C
  (make-refining-comparator
   (make-inexact-real-comparator 0.1   round-to-epsilon 'error)
   (make-inexact-real-comparator 0.01  round-to-epsilon 'error)
   (make-inexact-real-comparator 0.001 round-to-epsilon 'error)))

;; type test
(let ((test-type (comparator-type-test-procedure C)))
  (test-type 1.1)       ⇒ #t
  (test-type 1)         ⇒ #f
  (test-type "ciao"))   ⇒ #f

;; type check
(let ((check-type (comparator-check-type-procedure C)))
  (check-type 1.1)      ⇒ #t
  (try
      (comparator-check-type C 1)
    (catch E
      ((&comparator-type-error)
       #t)
      (else E))))       ⇒ #t

;; comparison
(let ((compare (comparator-comparison-procedure C)))
  (compare 1. 1.)       ⇒ 0
  (compare 2. 1.)       ⇒ +1
  (compare 1. 2.)       ⇒ -1

  ;;Equal according to the first comparator,
  ;;different according to the second.
  (compare 1.00 1.05)   ⇒ -1
  (compare 1.05 1.00)   ⇒ +1

  ;;Equal according to the first and second
  ;;comparators, different according to the
  ;;third.
  (compare 1.0   1.005) ⇒ -1
  (compare 1.005 1.0)   ⇒ +1

  ;;Equal according to the first, second and
  ;;third comparators.
  (compare 1.0 1.0005)  ⇒ 0
  (compare 1.0005 1.0)  ⇒ 0

  (try
      (compare 1 "ciao")
    (catch E
      ((&comparator-type-error)
       #t)
      (else E))))       ⇒ #t

;; hash
(let ((hash (comparator-hash-function C)))
  (non-negative-exact-integer? (hash 1.2))      ⇒ #t

  (try
      (hash 1+2i)
    (catch E
      ((&comparator-type-error)
       #t)
      (else E))))       ⇒ #t