1;;; 2;;; srfi-114 - comparators 3;;; 4;;; Copyright (c) 2014-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; Basic support of comparators are built-in, for the built-in 35;; data structures such as hashtables would make use of them. 36;; This module provides complete set of srfi-114 37 38;; TODO: Importing srfi-114 shadows make-comparator, but many procedures 39;; here are generally useful. We might want to split those procs 40;; in separate module so that they can be used without worring 41;; different make-comparator APIs. 42;; TODO: Comparator combinators are written for srfi-114 and assumes 43;; the given comparator has comparison proc. We might be able to optimize 44;; it by checking if the passed one is srfi-128. 45 46(define-module srfi-114 47 (use gauche.uvector) 48 (use srfi-162) ; comparator-min, comparator-max 49 (export comparator? ;builtin (srfi-128) 50 comparator-comparison-procedure? 51 comparator-hash-function? 52 53 boolean-comparator char-comparator char-ci-comparator 54 string-comparator string-ci-comparator symbol-comparator 55 exact-integer-comparator integer-comparator rational-comparator 56 real-comparator complex-comparator number-comparator 57 pair-comparator list-comparator vector-comparator 58 bytevector-comparator uvector-comparator ;all builtin 59 60 default-comparator ;builtin 61 62 (rename make-comparator/compare make-comparator) ;builtin 63 make-car-comparator make-cdr-comparator 64 65 make-inexact-real-comparator 66 make-vector-comparator ; builtin 67 make-bytevector-comparator 68 make-list-comparator ; builtin 69 make-vectorwise-comparator make-listwise-comparator 70 make-pair-comparator ; builtin 71 make-improper-list-comparator 72 make-selecting-comparator make-refining-comparator 73 make-reverse-comparator make-debug-comparator 74 75 eq-comparator ;builtin 76 eqv-comparator ;builtin 77 equal-comparator ;builtin 78 79 comparator-type-test-procedure 80 comparator-equality-predicate ;builtin 81 comparator-comparison-procedure ;builtin 82 comparator-hash-function ;builtin 83 84 comparator-test-type ;builtin 85 comparator-check-type ;builtin 86 comparator-equal? 87 comparator-compare ;builtin 88 comparator-hash ;builtin 89 90 make-comparison< make-comparison> make-comparison<= 91 make-comparison>= make-comparison=/< make-comparison=/> 92 93 if3 if=? if<? if>? if<=? if>=? if-not=? 94 95 =? <? >? <=? >=? ;builtin 96 97 make=? make<? make>? make<=? make>=? 98 99 in-open-interval? in-closed-interval? 100 in-open-closed-interval? in-closed-open-interval? 101 102 comparator-min comparator-max ;srfi-162 103 )) 104(select-module srfi-114) 105 106;;; 107;;; Predicates 108;;; 109(define (comparator-comparison-procedure? c) 110 (comparator-ordered? c)) ;srfi-128 111(define (comparator-hash-function? c) 112 (comparator-hashable? c)) ;srfi-128 113(define (comparator-type-test-procedure c) 114 (comparator-type-test-predicate c)) ;srfi-128 115(define (comparator-equal? c a b) (=? c a b)) 116 117;;; 118;;; Inexact comparator 119;;; 120 121(define (((%make-scaler rounder) epsilon) num) (rounder (/ num epsilon))) 122(define %scale-round (%make-scaler round)) 123(define %scale-ceiling (%make-scaler ceiling)) 124(define %scale-floor (%make-scaler floor)) 125(define %scale-truncate (%make-scaler truncate)) 126 127(define (%handle-nan which num nan-handling) 128 (case nan-handling 129 [(min) (if (eq? which 'a) -1 1)] 130 [(max) (if (eq? which 'a) 1 -1)] 131 [else 132 (if (applicable? nan-handling <real>) 133 (nan-handling num) 134 (error "nan-handling argument must be either a procedure taking one argument, or a symbol min or max, but got:" nan-handling))])) 135 136(define (make-inexact-real-comparator epsilon rounding nan-handling) 137 (define scaler 138 (case rounding 139 [(round) (%scale-round epsilon)] 140 [(ceiling) (%scale-ceiling epsilon)] 141 [(floor) (%scale-floor epsilon)] 142 [(truncate) (%scale-truncate epsilon)] 143 [else (if (applicable? rounding <real> <real>) 144 (^[num] (rounding num epsilon)) 145 (error "make-inexact-comparator requires `rounding' argument to be either a procedure taking two real numbers, or one of the symbols 'round, 'ceiling, 'floor or 'truncate, but got:" rounding))])) 146 (define nan-handler 147 (case nan-handling 148 [(min) (^[which num] (if (eq? which 'a) -1 1))] 149 [(max) (^[which num] (if (eq? which 'a) 1 -1))] 150 [(error) (^[which num] 151 (error "attempt to compare NaN with non-NaN: ~a" num))] 152 [else 153 (if (applicable? nan-handling <real>) 154 (^[which num] (nan-handling num)) 155 (error "make-inexact-comparator requires `nan-handling' argument to be either a procedure taking one real number, or one of the symbols 'min or 'max, but got:" nan-handling))])) 156 (make-comparator/compare real? 157 #t 158 (^[a b] 159 (if (nan? a) 160 (if (nan? b) 161 0 162 (nan-handler 'a b)) 163 (if (nan? b) 164 (nan-handler 'b a) 165 (compare (scaler a) (scaler b))))) 166 (^[a] (if (nan? a) 0 (eqv-hash (scaler a)))))) 167 168;;; 169;;; Comparator transformers 170;;; 171 172(define (make-car-comparator comparator) 173 (make-key-comparator comparator pair? car)) 174 175(define (make-cdr-comparator comparator) 176 (make-key-comparator comparator pair? cdr)) 177 178(define (make-listwise-comparator test elt-comparator null? car cdr) 179 (make-list-comparator elt-comparator test null? car cdr)) ; srfi-128 180 181(define (make-vectorwise-comparator test elt-comparator len ref) 182 (make-vector-comparator elt-comparator test len ref)) ; srfi-128 183 184(define (make-bytevector-comparator elt-comparator) 185 (make-vectorwise-comparator u8vector? elt-comparator 186 u8vector-length u8vector-ref)) 187 188(define (make-improper-list-comparator elt-comparator) 189 ($ make-comparator/compare #t 190 (^[a b] (cond [(null? a) (null? b)] 191 [(pair? a) 192 (and (pair? b) 193 (comparator-equal? elt-comparator (car a) (car b)) 194 (comparator-equal? elt-comparator (cdr a) (cdr b)))] 195 [else (comparator-equal? elt-comparator a b)])) 196 (and (comparator-comparison-procedure? elt-comparator) 197 (^[a b] (cond [(null? a) (if (null? b) 0 -1)] 198 [(pair? a) 199 (if (pair? b) 200 (let1 r (comparator-compare elt-comparator 201 (car a) (car b)) 202 (if (= r 0) 203 (comparator-compare elt-comparator 204 (cdr a) (cdr b)) 205 r)) 206 -1)] 207 [else (comparator-compare elt-comparator a b)]))) 208 (and (comparator-hash-function? elt-comparator) 209 (^x (if (pair? x) 210 (combine-hash-value (comparator-hash elt-comparator (car x)) 211 (comparator-hash elt-comparator (cdr x))) 212 (comparator-hash elt-comparator x)))))) 213 214(define (make-selecting-comparator cmp . cmps) 215 (define (selector x) ; returns a comparator 216 (let loop ([cmp cmp] [cmps cmps]) 217 (cond [(comparator-test-type cmp x) cmp] 218 [(null? cmps) #f] 219 [else (loop (car cmps) (cdr cmps))]))) 220 (define (selector2 a b) ; returns a comparator 221 (let loop ([cmp cmp] [cmps cmps]) 222 (cond [(and (comparator-test-type cmp a) 223 (comparator-test-type cmp b)) 224 cmp] 225 [(null? cmps) #f] 226 [else (loop (car cmps) (cdr cmps))]))) 227 (make-comparator/compare 228 (^x (boolean (selector x))) 229 (^[a b] (and-let* ([cmp (selector2 a b)]) 230 (comparator-equal? cmp a b))) 231 (^[a b] (if-let1 cmp (selector2 a b) 232 (comparator-compare cmp a b) 233 (error "argument isn't comparable"))) 234 (^x (if-let1 cmp (selector x) 235 (comparator-hash cmp x) 236 (error "argument isn't hashable:" x))))) 237 238(define (make-refining-comparator cmp . cmps) 239 (define (selector x) ; returns a comparator 240 (let loop ([cmp cmp] [cmps cmps]) 241 (cond [(comparator-test-type cmp x) cmp] 242 [(null? cmps) #f] 243 [else (loop (car cmps) (cdr cmps))]))) 244 (define (selector2 a b cmps) ; returns a comparator and the rest 245 (let loop ([cmps cmps]) 246 (cond [(null? cmps) (values #f #f)] 247 [(and (comparator-test-type (car cmps) a) 248 (comparator-test-type (car cmps) b)) 249 (values (car cmps) (cdr cmps))] 250 [else (loop (cdr cmps))]))) 251 (make-comparator/compare 252 (^x (boolean (selector x))) 253 (^[a b] (receive (cmp _) (selector2 a b (cons cmp cmps)) 254 (if cmp 255 (comparator-equal? cmp a b) 256 #f))) 257 (^[a b] (let loop ([cmps (cons cmp cmps)] 258 [r #f]) 259 (receive (cmp cmps) (selector2 a b cmps) 260 (if cmp 261 (let1 r (comparator-compare cmp a b) 262 (if (= r 0) 263 (loop cmps r) 264 r)) 265 (or r (error "argument isn't comparable")))))) 266 (^x (if-let1 cmp (selector x) 267 (comparator-hash cmp x) 268 (error "argument isn't hashable:" x))))) 269 270(define (make-reverse-comparator cmp) 271 (make-comparator/compare (comparator-type-test-procedure cmp) 272 (comparator-equality-predicate cmp) 273 (and (comparator-comparison-procedure? cmp) 274 (^[a b] (- (comparator-compare cmp a b)))) 275 (and (comparator-hash-function? cmp) 276 (comparator-hash-function cmp)))) 277 278(define (make-debug-comparator cmp) 279 cmp) ;WRITEME 280 281(define (make-comparison< pred) 282 (^[a b] (cond [(pred a b) -1] 283 [(pred b a) 1] 284 [else 0]))) 285 286(define (make-comparison> pred) 287 (^[a b] (cond [(pred a b) 1] 288 [(pred b a) -1] 289 [else 0]))) 290 291(define (make-comparison<= pred) 292 (^[a b] (if (pred a b) (if (pred b a) 0 -1) 1))) 293 294(define (make-comparison>= pred) 295 (^[a b] (if (pred a b) (if (pred b a) 0 1) -1))) 296 297(define (make-comparison=/< eq-pred lt-pred) 298 (^[a b] (cond [(eq-pred a b) 0] 299 [(lt-pred a b) -1] 300 [else 1]))) 301 302(define (make-comparison=/> eq-pred gt-pred) 303 (^[a b] (cond [(eq-pred a b) 0] 304 [(gt-pred a b) 1] 305 [else -1]))) 306 307(define-syntax if3 308 (syntax-rules () 309 [(_ expr less equal greater) 310 (let1 r expr 311 (cond [(= r 0) equal] 312 [(< r 0) less] 313 [else greater]))] 314 [(_ . x) (syntax-error "malformed if3:" (if3 . x))])) 315 316(define-syntax define-ifx 317 (syntax-rules () 318 [(_ name op) 319 (define-syntax name 320 (syntax-rules () 321 [(_ expr then . opt) (if (op expr 0) then . opt)]))])) 322 323(define (!= a b) (not (= a b))) 324 325(define-ifx if=? =) 326(define-ifx if<? <) 327(define-ifx if>? >) 328(define-ifx if<=? <=) 329(define-ifx if>=? >=) 330(define-ifx if-not=? !=) 331 332(define (make=? comparator) 333 (rec (cmp a b . args) 334 (and (comparator-equal? comparator a b) 335 (or (null? args) 336 (apply cmp b args))))) 337 338(define (gen-make-x op) 339 (^[comparator] 340 (rec (cmp a b . args) 341 (let1 r (comparator-compare comparator a b) 342 (and (op r 0) 343 (if (null? args) 344 #t 345 (apply cmp b args))))))) 346 347(define make<? (gen-make-x <)) 348(define make>? (gen-make-x >)) 349(define make<=? (gen-make-x <=)) 350(define make>=? (gen-make-x >=)) 351 352(define in-open-interval? 353 (case-lambda 354 [(cmp a b c) (<? cmp a b c)] 355 [(a b c) (<? default-comparator a b c)])) 356 357(define in-closed-interval? 358 (case-lambda 359 [(cmp a b c) (<=? cmp a b c)] 360 [(a b c) (<=? default-comparator a b c)])) 361 362(define in-open-closed-interval? 363 (case-lambda 364 [(cmp a b c) (and (<? cmp a b) (<=? cmp b c))] 365 [(a b c) (in-open-closed-interval? default-comparator a b c)])) 366 367(define in-closed-open-interval? 368 (case-lambda 369 [(cmp a b c) (and (<=? cmp a b) (<? cmp b c))] 370 [(a b c) (in-closed-open-interval? default-comparator a b c)])) 371