;;;; hash-table-tests-incl.scm

;;

(test-group "Procedures"
  (test-assert (eq? hash equal?-hash))
  (test-assert (eq? hash-by-identity eq?-hash))

  (test-assert (fixnum? (eq?-hash 1/2)))
  (test-assert (fixnum? (eq?-hash 1+1i)))
  (test-assert (fixnum? (eqv?-hash 1/2)))
  (test-assert (fixnum? (eqv?-hash 1+1i)))
  (test-assert (fixnum? (equal?-hash 1/2)))
  (test-assert (fixnum? (eqv?-hash 1+1i)))
)

(test-group "HT - No Parameters"
  (let ((ht (make-hash-table)))
    (test-assert (hash-table? ht))
    (test-assert (eq? equal? (hash-table-equivalence-function ht)))
    (test-assert (eq? equal?-hash (hash-table-hash-function ht)))
    (test-assert (not (hash-table-has-initial? ht))) )
)

(test-group "HT - Test Parameter"
  (let ((ht (make-hash-table eq?)))
    (test-assert (hash-table? ht))
    (test-assert (eq? eq? (hash-table-equivalence-function ht)))
    (test-assert (eq? eq?-hash (hash-table-hash-function ht)))
    (test-assert (not (hash-table-has-initial? ht))) )
)

(test-group "HT - Number Test Parameter"
  (let ((ht (make-hash-table =)))
    (test-assert (hash-table? ht))
    (test-assert (eq? = (hash-table-equivalence-function ht)))
    (test-assert (eq? number-hash (hash-table-hash-function ht)))
    (test-assert (not (hash-table-has-initial? ht))) )
)

(test-group "HT - All Optional Parameters"
  (let ((ht (make-hash-table eqv? eqv?-hash 23)))
    (test-assert (hash-table? ht))
    (test-assert (not (hash-table-has-initial? ht))) )
)

(test-group "HT - All Optional & Keyword Parameters"
  (let ((ht (make-hash-table eqv? eqv?-hash 23
                             #:test equal? #:hash equal?-hash
                             #:initial 'foo
                             #:size 500
                             #:min-load 0.45 #:max-load 0.85
                             #:weak-keys #t #:weak-values #t)) )

    (test-group "HT - Properties"
      (test-assert (hash-table? ht))
      ;NOTE would need to -X <HT> to use `cond-expand'
      (cond ((feature? 'srfi-69-weak)
              (test-assert (hash-table-weak-keys ht))
              (test-assert (hash-table-weak-values ht)) )
            (else
              (test-assert (not (hash-table-weak-keys ht)))
              (test-assert (not (hash-table-weak-values ht))) ) )
      (test-assert (eq? equal? (hash-table-equivalence-function ht)))
      (test-assert (eq? equal?-hash (hash-table-hash-function ht)))
      (test 0.45 (hash-table-min-load ht))
      (test 0.85 (hash-table-max-load ht))
      (test-assert (hash-table-has-initial? ht))
      (test-assert (eq? 'foo (hash-table-initial ht)))
    )

    (test-group "HT - Insert with setter"
      (set! (hash-table-ref ht 23.0) 'bar)
      (test-assert (eq? (hash-table-ref ht 23.0) 'bar))
    )

    (test-group "HT - Insert with update!"
      (hash-table-update! ht 'baz identity (lambda () 'foo))
      (test-assert (eq? (hash-table-ref ht 'baz) 'foo))
      (test 2 (hash-table-size ht))
    )

    (test-group "HT - A-List"
      (let ([alist (hash-table->alist ht)])
        (test-assert (list? alist))
        (test (hash-table-size ht) (length alist))
        (test-assert (eq? (alist-ref 23.0 alist) 'bar))
        (test-assert (eq? (alist-ref 'baz alist) 'foo)) )
    )

    (test-group "HT - set! overwrites"
      (hash-table-set! ht 23.0 'foo-bar)
      (test-assert (eq? (hash-table-ref ht 23.0) 'foo-bar))
    )

    (test-group "HT - Delete"
      (test-assert (hash-table-delete! ht 23.0))
      (test-assert (not (hash-table-exists? ht 23.0)))
      (test 1 (hash-table-size ht))
    )

    (test-group "HT - Remove"
      (test-assert (hash-table-remove! ht (lambda (k v) (eq? k 'baz))))
      (test-assert (not (hash-table-exists? ht 'baz)))
      (test 0 (hash-table-size ht))
    )
  )
)

(test-group "HT - Make from A-List"
  (let ((ht (alist->hash-table '(("abc" . #t) ("cbs" . #t) ("cnn" . #f)))))
    (test-assert (hash-table? ht))
    (test 3 (hash-table-size ht)) )
)

(test-group "HT - Copy"
  (let* ((l '((1 a) (2 b) (3 c)))
         (ht (alist->hash-table l))
         (ht2 (hash-table-copy ht)) )
    ;(gloss l " -- " (hash-table->alist ht2))
    (test (hash-table-size ht2) (hash-table-size ht))
    (test l (sort (hash-table->alist ht2) (lambda (e1 e2) (< (car e1) (car e2)))))
    ;; Ensure that lookup still works (#905, randomization value was reset)
    (test '(a) (hash-table-ref ht2 1)) )
)

(let ((ht (alist->hash-table '(("abc" . #t) ("cbs" . #t) ("cnn" . #f)))))

  (test-group "HT - Merge!"
    (let ([ht2 (make-hash-table)])
      (set! (hash-table-ref ht2 23.0) 'bar)
      (set! (hash-table-ref ht2 'baz) 'foo)
      (let ([ht3 (hash-table-merge! ht2 ht)])
        (test-assert (eq? ht3 ht2))
        (test-assert (not (eq? ht3 ht)))
        (let ([alist (hash-table->alist ht3)])
          (test-assert (list? alist))
          (test 5 (length alist))
          (test-assert (alist-ref "abc" alist equal?))
          (test-assert (alist-ref "cbs" alist equal?))
          (test-assert (not (alist-ref "cnn" alist equal?)))
          (test 'bar (alist-ref 23.0 alist))
          (test 'foo (alist-ref 'baz alist)) ) ) )
  )

  (test-group "HT - Merge"
    (let ([ht2 (make-hash-table)])
      (set! (hash-table-ref ht2 23.0) 'bar)
      (set! (hash-table-ref ht2 'baz) 'foo)
      (let ([ht3 (hash-table-merge ht2 ht)])
        (test-assert (not (eq? ht3 ht2)))
        (test-assert (not (eq? ht3 ht)))
        (let ([alist (hash-table->alist ht3)])
          (test-assert (list? alist))
          (test 5 (length alist))
          (test-assert (alist-ref "abc" alist equal?))
          (test-assert (alist-ref "cbs" alist equal?))
          (test-assert (not (alist-ref "cnn" alist equal?)))
          (test 'bar (alist-ref 23.0 alist))
          (test 'foo (alist-ref 'baz alist)) ) ) )
  )

  (test-group "HT - Map"
    (let ([alist (hash-table-map ht (lambda (k v) (cons k v)))])
      (test-assert (list? alist))
      (test 3 (length alist)) )
  )

  (test-group "HT - Fold"
    (let ([alist (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '())])
      (test-assert (list? alist))
      (test 3 (length alist)) )
  )
)

(test-group "HT - Built-in string hash function"
  (let ((ht (make-hash-table string=?)))
    (hash-table-set! ht "test" 123)
    (hash-table-set! ht "one" 1)
    (test 123 (hash-table-ref ht "test"))
    (test 1 (hash-table-ref ht "one")) )
)

;; Issue #818, found by Jim Ursetto (srfi-13 defines its own string-hash)
(test-group "HT - After overwriting 'string-hash' should still work"
  (let ((ht (the (or false hash-table) #f))
        ;save
        (orig-fn string-hash) )
    (set! string-hash (lambda _ (error "Wrong string-hash called")))
    (set! ht (make-hash-table string=?))
    (hash-table-set! ht "foo" "bar")
    (test "bar" (hash-table-ref ht "foo"))
    ;restore
    (set! string-hash orig-fn) )
)

(test-group "HT - custom hash function"
  (let ((ht (make-hash-table equal? (lambda (object bounds)
                                      (case object
                                        ((test) 0)
                                        ((one two) 1)
                                        (else (+ bounds 1)))))))
    (hash-table-set! ht 'test 123)
    (hash-table-set! ht 'one 1)
    (hash-table-set! ht 'two 2)
    (test 123 (hash-table-ref ht 'test))
    (test 1 (hash-table-ref ht 'one))
    (test 2 (hash-table-ref ht 'two)) )
)

;(gloss "will result in a referenced but unbound: ht")
(test-group "HT - out of bounds value is caught"
  (test-assert (handle-exceptions exn #t (hash-table-set! ht 'out-of-bounds 123) #f))
)

(test-group "Hash collision weaknesses"
  ;; If these fail, it might be bad luck caused by the randomization/modulo combo
  ;; So don't *immediately* dismiss a hash implementation when it fails here
  (test-assert "rna affects the result" (not (= (hash "a" 10 1) (hash "a" 10 2))))
  (test-assert "hash of \"\\x00\" not 0" (not (= (hash (make-string 1 #\nul)) 0)))
  ;; Long identical suffixes should not hash to the same value
  (test-assert (not (= (hash (string-append (make-string 1000000 #\a)
                                            (make-string 1000000 #\c)))
                       (hash (string-append (make-string 1000000 #\b)
                                            (make-string 1000000 #\c))))))
  ;; Same for prefixes
  (test-assert (not (= (hash (string-append (make-string 1000000 #\a)
                                            (make-string 1000000 #\b)))
                       (hash (string-append (make-string 1000000 #\a)
                                            (make-string 1000000 #\c))))))
  ;; And palindromes, too
  (test-assert (not (= (hash (string-append (make-string 1000000 #\a)
                                            (make-string 1000000 #\b)
                                            (make-string 1000000 #\a)))
                       (hash (string-append (make-string 1000000 #\a)
                                            (make-string 1000000 #\c)
                                            (make-string 1000000 #\a))))))
  ;; differing number of nul bytes should not be identical
  (test-assert (not (= (hash (make-string 1 #\nul))
                       (hash (make-string 2 #\nul)))))
  ;; ensure very long NUL strings don't cause the random value to get pushed out
  (test-assert (not (= (hash (make-string 1000000 #\nul))
                       (hash (make-string 1000001 #\nul)))))
  ;;
  (test-assert (not (= (hash (gensym))
                       (hash (gensym)))))
)

;FIXME need real randomness measure & appropriate test of triple32 mixing

#;
(test-group "Hash collision weaknesses w/ triple32 mixing"
  (define mixedhash (hash-mix/triple32 hash))
  ;; If these fail, it might be bad luck caused by the randomization/modulo combo
  ;; So don't *immediately* dismiss a hash implementation when it fails here
  (test-assert "rna affects the result" (not (= (mixedhash "a" 10 1) (mixedhash "a" 10 2))))
  (test-assert "hash of \"\\x00\" not 0" (not (= (mixedhash (make-string 1 #\nul)) 0)))
  ;; Long identical suffixes should not hash to the same value
  (test-assert (not (= (mixedhash (string-append (make-string 1000000 #\a)
                                                 (make-string 1000000 #\c)))
                       (mixedhash (string-append (make-string 1000000 #\b)
                                                 (make-string 1000000 #\c))))))
  ;; Same for prefixes
  (test-assert (not (= (mixedhash (string-append (make-string 1000000 #\a)
                                                 (make-string 1000000 #\b)))
                       (mixedhash (string-append (make-string 1000000 #\a)
                                                 (make-string 1000000 #\c))))))
  ;; And palindromes, too
  (test-assert (not (= (mixedhash (string-append (make-string 1000000 #\a)
                                                 (make-string 1000000 #\b)
                                                 (make-string 1000000 #\a)))
                       (mixedhash (string-append (make-string 1000000 #\a)
                                                 (make-string 1000000 #\c)
                                                 (make-string 1000000 #\a))))))
  ;; differing number of nul bytes should not be identical
  (test-assert (not (= (mixedhash (make-string 1 #\nul))
                       (mixedhash (make-string 2 #\nul)))))
  ;; ensure very long NUL strings don't cause the random value to get pushed out
  (test-assert (not (= (mixedhash (make-string 1000000 #\nul))
                       (mixedhash (make-string 1000001 #\nul)))))
  ;;
  (test-assert (not (= (mixedhash (gensym))
                       (mixedhash (gensym)))))
)

;;

(test-group "HT - recursive depth/length"
  (test-assert (fixnum? (recursive-hash-max-depth)))
  (test-assert (positive? (recursive-hash-max-depth)))
  (test-assert (fixnum? (recursive-hash-max-length)))
  (test-assert (positive? (recursive-hash-max-length)))
)

(test-group "HT - recursive depth hashes <>"
(let ((dd (recursive-hash-max-depth))
      (tls (list (pseudo-random-integer 100000) (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000) (list (pseudo-random-integer 100000))))))))))))))))
  (let ((hsh1 (equal?-hash tls 536870912 0)))
    (recursive-hash-max-depth 10)
    (test-assert (fx= 10 (recursive-hash-max-depth)))
    (let ((hsh2 (equal?-hash tls 536870912 0)))
      (recursive-hash-max-depth dd)
      ;(gloss hsh1 "<?>" hsh2)
      (test-assert (not (= hsh1 hsh2))) ) ) )
)

(test-group "HT - recursive length hashes <>"
(let ((dl (recursive-hash-max-length))
      (tv (vector (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000) (pseudo-random-integer 100000))))
  (let ((hsh1 (equal?-hash tv 536870912 0)))
    (recursive-hash-max-length 10)
    (test-assert (fx= 10 (recursive-hash-max-length)))
    (let ((hsh2 (equal?-hash tv 536870912 0)))
      (recursive-hash-max-length dl)
      ;(gloss hsh1  "<?>" hsh2)
      (test-assert (not (= hsh1 hsh2))) ) ) )
)

;;keyword vs. symbol issue
(test-group "HT - keyword vs. symbol hash"
  (test (keyword-hash #:foo) (eq?-hash #:foo))
  (test (keyword-hash #:foo) (eqv?-hash #:foo))
  (test (keyword-hash #:foo) (equal?-hash #:foo))
)

;; Stress Test

(define-constant STRESS-SIZE 100000)

(print)
(print "*** HT - Stress Test " STRESS-SIZE " Fixnum Key Items ***")
(let ((ht (make-hash-table eq?)))

  (print "  " "--- (overhead) ---")
  (time
    (do ([i 0 (fx+ i 1)])
        [(fx= i STRESS-SIZE)] ) )

  (print "  " "--- Insert ---")
  (time
    (do ([i 0 (fx+ i 1)])
        [(fx= i STRESS-SIZE)]
      (hash-table-set! ht i i) ) )
  (assert (fx= STRESS-SIZE (hash-table-size ht)))

  (print "  " "--- Retrieve ---")
  (time
    (do ([i 0 (fx+ i 1)])
        [(fx= i STRESS-SIZE)]
      (assert (fx= i (hash-table-ref ht i))) ) ) )