;;;; Main part of the SRFI 114 reference implementation

;;; "There are two ways of constructing a software design: One way is to
;;; make it so simple that there are obviously no deficiencies, and the
;;; other way is to make it so complicated that there are no *obvious*
;;; deficiencies." --Tony Hoare

;;; Comparison syntax (because syntax must be defined before it is used)

;; Arithmetic if
(define-syntax comparator-if<=>
  (syntax-rules ()
    ((if<=> a b less equal greater)
     (comparator-if<=> (make-default-comparator) a b less equal greater))
    ((comparator-if<=> comparator a b less equal greater)
     (cond
       ((=? comparator a b) equal)
       ((<? comparator a b) less)
       (else greater)))))

;;; Definition of comparator records with accessors and basic comparator

(: comparator? (* --> boolean : :comparator:))
(: comparator-type-test-predicate (:comparator: --> :type-test:))
(: comparator-equality-predicate (:comparator: --> :comparsion-test:))
(: comparator-ordering-predicate (:comparator: --> :comparsion-test:))
(: comparator-hash-function (:comparator: --> :hash-function:))
(: comparator-ordered? (:comparator: --> boolean))
(: comparator-hashable? (:comparator: --> boolean))
(define-record-type comparator
  (make-raw-comparator type-test equality ordering hash ordering? hash?)
  comparator?
  (type-test comparator-type-test-predicate)
  (equality comparator-equality-predicate)
  (ordering comparator-ordering-predicate)
  (hash comparator-hash-function)
  (ordering? comparator-ordered?)
  (hash? comparator-hashable?))

;; Public constructor
(: make-comparator
   ((or true :type-test:)
    (or true :comparsion-test:)
    (or false :comparsion-test:)
    (or false :hash-function:)
    --> :comparator:))
(define (make-comparator type-test equality ordering hash)
  (make-raw-comparator
    (if (eq? type-test #t) (lambda (x) #t) type-test)
    (if (eq? equality #t) (lambda (x y) (eqv? (ordering x y) 0)) equality)
    (if ordering ordering (lambda (x y) (error "ordering not supported")))
    (if hash hash (lambda (x y) (error "hashing not supported")))
    (if ordering #t #f)
    (if hash #t #f)))

;;; Invokers

;; Invoke the test type
(: comparator-test-type (:comparator: * --> boolean))
(define (comparator-test-type comparator obj)
  ((comparator-type-test-predicate comparator) obj))

;; Invoke the test type and throw an error if it fails
(: comparator-check-type (:comparator: * --> true))
(define (comparator-check-type comparator obj)
  (if (comparator-test-type comparator obj)
    #t
    (error "comparator type check failed" comparator obj)))

;; Invoke the hash function
(: comparator-hash (:comparator: * --> :hash-code:))
(define (comparator-hash comparator obj)
  ((comparator-hash-function comparator) obj))

;;; Comparison predicates

;; Binary versions for internal use

(: binary=? (:comparator: * * --> boolean))
(define (binary=? comparator a b)
  ((comparator-equality-predicate comparator) a b))

(: binary<? (:comparator: * * --> boolean))
(define (binary<? comparator a b)
  ((comparator-ordering-predicate comparator) a b))

(: binary>? (:comparator: * * --> boolean))
(define (binary>? comparator a b)
  (binary<? comparator b a))

(: binary<=? (:comparator: * * --> boolean))
(define (binary<=? comparator a b)
  (not (binary>? comparator a b)))

(: binary>=? (:comparator: * * --> boolean))
(define (binary>=? comparator a b)
  (not (binary<? comparator a b)))

;; General versions for export

(: =? (:comparator: * * &rest * * --> boolean))
(define (=? comparator a b . objs)
  (let loop ((a a) (b b) (objs objs))
    (and (binary=? comparator a b)
	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))

(: <? (:comparator: * * &rest * * --> boolean))
(define (<? comparator a b . objs)
  (let loop ((a a) (b b) (objs objs))
    (and (binary<? comparator a b)
	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))

(: >? (:comparator: * * &rest * * --> boolean))
(define (>? comparator a b . objs)
  (let loop ((a a) (b b) (objs objs))
    (and (binary>? comparator a b)
	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))

(: <=? (:comparator: * * &rest * * --> boolean))
(define (<=? comparator a b . objs)
  (let loop ((a a) (b b) (objs objs))
    (and (binary<=? comparator a b)
	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))

(: >=? (:comparator: * * &rest * * --> boolean))
(define (>=? comparator a b . objs)
  (let loop ((a a) (b b) (objs objs))
    (and (binary>=? comparator a b)
	 (if (null? objs) #t (loop b (car objs) (cdr objs))))))


;;; Simple ordering and hash functions

(: boolean<? (boolean boolean --> boolean))
(define (boolean<? a b)
  ;; #f < #t but not otherwise
  (and (not a) b))

;; Define dummy value of salt
(: salt :hash-code:)
(define salt 2)

(: boolean-hash (boolean --> :hash-code:))
(define (boolean-hash obj)
  (* salt (if obj 1 2)))

(: char-hash (char --> :hash-code:))
(define (char-hash obj)
  (* salt (char->integer obj)))

(: char-ci-hash (char --> :hash-code:))
(define (char-ci-hash obj)
    (* salt (char->integer (char-foldcase obj))))

(: number-hash (number --> :hash-code:))
(define (number-hash obj)
  (cond
    ((nan? obj) salt)
    ((and (infinite? obj) (positive? obj)) (* salt salt))
    ((infinite? obj) (* salt salt salt))
    ((real? obj) (abs (exact obj)))
    (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj))))))

;; Lexicographic ordering of complex numbers
(: complex<? (number number --> boolean)) ;; FIXME
(define (complex<? a b)
  (if (= (real-part a) (real-part b))
    (< (imag-part a) (imag-part b))
    (< (real-part a) (real-part b))))

(: string-ci-hash (string --> :hash-code:))
(define (string-ci-hash obj)
    (string-hash (string-foldcase obj)))

(: symbol<? (symbol symbol --> boolean))
(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))

(: symbol-hash (symbol --> :hash-code:))
(define (symbol-hash obj)
  (string-hash (symbol->string obj)))

;;; Wrapped equality predicates
;;; These comparators don't have ordering functions.

(: make-eq-comparator (--> :comparator:))
(define (make-eq-comparator)
  (make-comparator #t eq? #f default-hash))

(: make-eqv-comparator (--> :comparator:))
(define (make-eqv-comparator)
  (make-comparator #t eqv? #f default-hash))

(: make-equal-comparator (--> :comparator:))
(define (make-equal-comparator)
  (make-comparator #t equal? #f default-hash))

;;; Sequence ordering and hash functions
;; The hash functions are based on djb2, but
;; modulo 2^20 instead of 2^32 in hopes of sticking to fixnums.
(: limit :hash-code:)
(define limit 1048576)

;; Return hash-accumulating object
(: make-hasher (:hash-code: --> (procedure (&optional :hash-code:) (or :hash-code: undefined))))
(define (make-hasher salt)
  (let ((result (* (abs (+ salt 1)) 5381)))
    (case-lambda
     (() result)
     ((n) (set! result (+ (modulo (* result 33) limit) n))))))

;;; Pair comparator
(: make-pair-comparator (:comparator: :comparator: --> :comparator:))
(define (make-pair-comparator car-comparator cdr-comparator)
   (make-comparator
     (make-pair-type-test car-comparator cdr-comparator)
     (make-pair=? car-comparator cdr-comparator)
     (make-pair<? car-comparator cdr-comparator)
     (make-pair-hash car-comparator cdr-comparator)))

(: make-pair-type-test (:comparator: :comparator: --> :type-test:))
(define (make-pair-type-test car-comparator cdr-comparator)
  (lambda (obj)
    (and (pair? obj)
         (comparator-test-type car-comparator (car obj))
         (comparator-test-type cdr-comparator (cdr obj)))))

(: make-pair=? (:comparator: :comparator: --> :comparsion-test:))
(define (make-pair=? car-comparator cdr-comparator)
   (lambda (a b)
     (and ((comparator-equality-predicate car-comparator) (car a) (car b))
          ((comparator-equality-predicate cdr-comparator) (cdr a) (cdr b)))))

(: make-pair<? (:comparator: :comparator: --> :comparsion-test:))
(define (make-pair<? car-comparator cdr-comparator)
   (lambda (a b)
      (if (=? car-comparator (car a) (car b))
        (<? cdr-comparator (cdr a) (cdr b))
        (<? car-comparator (car a) (car b)))))

(: make-hash (:comparator: :comparator: --> :hash-function:))
(define (make-pair-hash car-comparator cdr-comparator)
   (lambda (obj)
     (let ((acc (make-hasher salt)))
       (acc (comparator-hash car-comparator (car obj)))
       (acc (comparator-hash cdr-comparator (cdr obj)))
       (acc))))

;;; List comparator

;; Cheap test for listness
(define (norp? obj) (or (null? obj) (pair? obj)))

(: make-list-comparator (:comparator: :type-test: :type-test: (procedure (*) *)  (procedure (*) *) --> :comparator:))
(define (make-list-comparator element-comparator type-test empty? head tail)
   (make-comparator
     (make-list-type-test element-comparator type-test empty? head tail)
     (make-list=? element-comparator type-test empty? head tail)
     (make-list<? element-comparator type-test empty? head tail)
     (make-list-hash element-comparator type-test empty? head tail)))


(define (make-list-type-test element-comparator type-test empty? head tail)
  (lambda (obj)
    (and
      (type-test obj)
      (let ((elem-type-test (comparator-type-test-predicate element-comparator)))
        (let loop ((obj obj))
          (cond
            ((empty? obj) #t)
            ((not (elem-type-test (head obj))) #f)
            (else (loop (tail obj)))))))))

(define (make-list=? element-comparator type-test empty? head tail)
  (lambda (a b)
    (let ((elem=? (comparator-equality-predicate element-comparator)))
      (let loop ((a a) (b b))
        (cond
          ((and (empty? a) (empty? b) #t))
          ((empty? a) #f)
          ((empty? b) #f)
          ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
          (else #f))))))

(define (make-list<? element-comparator type-test empty? head tail)
  (lambda (a b)
    (let ((elem=? (comparator-equality-predicate element-comparator))
          (elem<? (comparator-ordering-predicate element-comparator)))
      (let loop ((a a) (b b))
        (cond
          ((and (empty? a) (empty? b) #f))
          ((empty? a) #t)
          ((empty? b) #f)
          ((elem=? (head a) (head b)) (loop (tail a) (tail b)))
          ((elem<? (head a) (head b)) #t)
          (else #f))))))

(define (make-list-hash element-comparator type-test empty? head tail)
  (lambda (obj)
    (let ((elem-hash (comparator-hash-function element-comparator))
          (acc (make-hasher salt)))
      (let loop ((obj obj))
        (cond
          ((empty? obj) (acc))
          (else (acc (head obj)) (loop (tail obj))))))))


;;; Vector comparator

(: make-vector-comparator (:comparator: :type-test: (procedure (*) fixnum) (procedure (* fixnum) *) --> :comparator:))
(define (make-vector-comparator element-comparator type-test length ref)
     (make-comparator
       (make-vector-type-test element-comparator type-test length ref)
       (make-vector=? element-comparator type-test length ref)
       (make-vector<? element-comparator type-test length ref)
       (make-vector-hash element-comparator type-test length ref)))

(define (make-vector-type-test element-comparator type-test length ref)
  (lambda (obj)
    (and
      (type-test obj)
      (let ((elem-type-test (comparator-type-test-predicate element-comparator))
            (len (length obj)))
        (let loop ((n 0))
          (cond
            ((= n len) #t)
            ((not (elem-type-test (ref obj n))) #f)
            (else (loop (+ n 1)))))))))

(define (make-vector=? element-comparator type-test length ref)
   (lambda (a b)
     (and
       (= (length a) (length b))
       (let ((elem=? (comparator-equality-predicate element-comparator))
             (len (length b)))
         (let loop ((n 0))
           (cond
             ((= n len) #t)
             ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
             (else #f)))))))

(define (make-vector<? element-comparator type-test length ref)
   (lambda (a b)
     (cond
       ((< (length a) (length b)) #t)
       ((> (length a) (length b)) #f)
        (else
         (let ((elem=? (comparator-equality-predicate element-comparator))
             (elem<? (comparator-ordering-predicate element-comparator))
             (len (length a)))
         (let loop ((n 0))
           (cond
             ((= n len) #f)
             ((elem=? (ref a n) (ref b n)) (loop (+ n 1)))
             ((elem<? (ref a n) (ref b n)) #t)
             (else #f))))))))

(define (make-vector-hash element-comparator type-test length ref)
  (lambda (obj)
    (let ((elem-hash (comparator-hash-function element-comparator))
          (acc (make-hasher salt))
          (len (length obj)))
      (let loop ((n 0))
        (cond
          ((> n len) (acc))
          (else (acc (ref obj n)) (loop (+ n 1))))))))

(: string-hash (string --> :hash-code:))
(define (string-hash obj)
  (let ((acc (make-hasher salt))
        (len (string-length obj)))
    (let loop ((n 0))
      (cond
        ((= n len) (acc))
        (else (acc (char->integer (string-ref obj n))) (loop (+ n 1)))))))