mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-19 13:49:16 +02:00
91 lines
2.3 KiB
Scheme
91 lines
2.3 KiB
Scheme
;;; Below are some default comparators provided by SRFI-114,
|
|
;;; but not SRFI-128, which this SRFI has transitioned to
|
|
;;; depend on. See the rationale for SRFI-128 as to why it is
|
|
;;; preferred in usage compared to SRFI-114.
|
|
|
|
;; Most if not all of this code is taken from SRFI-114
|
|
|
|
; (define exact inexact->exact)
|
|
|
|
(define string-foldcase string-downcase)
|
|
|
|
(define (make-comparison=/< = <)
|
|
(lambda (a b)
|
|
(cond
|
|
((= a b) 0)
|
|
((< a b) -1)
|
|
(else 1))))
|
|
|
|
;; Comparison procedure for real numbers only
|
|
(define (real-comparison a b)
|
|
(cond
|
|
((< a b) -1)
|
|
((> a b) 1)
|
|
(else 0)))
|
|
|
|
;; Comparison procedure for non-real numbers.
|
|
(define (complex-comparison a b)
|
|
(let ((real-result (real-comparison (real-part a) (real-part b))))
|
|
(if (= real-result 0)
|
|
(real-comparison (imag-part a) (imag-part b))
|
|
real-result)))
|
|
|
|
(define (number-hash obj) (exact (abs obj)))
|
|
|
|
(define number-comparator
|
|
(make-comparator number? = complex-comparison number-hash))
|
|
|
|
(define char-comparison (make-comparison=/< char=? char<?))
|
|
|
|
(define (char-hash obj) (abs (char->integer obj)))
|
|
|
|
(define char-comparator
|
|
(make-comparator char? char=? char-comparison char-hash))
|
|
|
|
;; Makes a hash function that works vectorwise
|
|
(define limit (expt 2 20))
|
|
|
|
(define (make-vectorwise-hash hash length ref)
|
|
(lambda (obj)
|
|
(let loop ((index (- (length obj) 1)) (result 5381))
|
|
(if (= index 0)
|
|
result
|
|
(let* ((prod (modulo (* result 33) limit))
|
|
(sum (modulo (+ prod (hash (ref obj index))) limit)))
|
|
(loop (- index 1) sum))))))
|
|
|
|
(define string-hash
|
|
(make-vectorwise-hash char-hash string-length string-ref))
|
|
|
|
(define string-comparison (make-comparison=/< string=? string<?))
|
|
|
|
(define string-ci-comparison (make-comparison=/< string-ci=? string-ci<?))
|
|
|
|
(define string-comparator
|
|
(make-comparator string? string=? string-comparison string-hash))
|
|
|
|
(define (string-ci-hash obj) (string-hash (string-foldcase obj)))
|
|
|
|
(define string-ci-comparator
|
|
(make-comparator string? string-ci=? string-ci-comparison string-ci-hash))
|
|
|
|
(define eq-comparator
|
|
(make-comparator
|
|
#t
|
|
eq?
|
|
#f
|
|
default-hash))
|
|
|
|
(define eqv-comparator
|
|
(make-comparator
|
|
#t
|
|
eqv?
|
|
#f
|
|
default-hash))
|
|
|
|
(define equal-comparator
|
|
(make-comparator
|
|
#t
|
|
equal?
|
|
#f
|
|
default-hash))
|