;;;; 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))
      (test-assert (hash-table-weak-keys ht))
      (test-assert (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 2 (hash-table-size ht))
        (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)))
    (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")) )
)

(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)) )
)

(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 (not (= (hash "a" 10 1) (hash "a" 10 2))))
  (test-assert (not (= (hash (make-string 1 #\nul) 10 10) 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)) 10 1)
                  (hash (string-append (make-string 1000000 #\b)
                                       (make-string 1000000 #\c)) 10 1))))
  ;; Same for prefixes
  (test-assert (not (= (hash (string-append (make-string 1000000 #\a)
                                       (make-string 1000000 #\b)) 10 1)
                  (hash (string-append (make-string 1000000 #\a)
                                       (make-string 1000000 #\c)) 10 1))))
  ;; And palindromes, too
  (test-assert (not (= (hash (string-append (make-string 1000000 #\a)
                                       (make-string 1000000 #\b)
                                       (make-string 1000000 #\a)) 10 1)
                  (hash (string-append (make-string 1000000 #\a)
                                       (make-string 1000000 #\c)
                                       (make-string 1000000 #\a)) 10 1))))
  ;; differing number of nul bytes should not be identical
  (test-assert (not (= (hash (make-string 1 #\nul) 10 1)
                  (hash (make-string 2 #\nul) 10 1))))
  ;; ensure very long NUL strings don't cause the random value to get pushed out
  (test-assert (not (= (hash (make-string 1000000 #\nul) 10 1)
                  (hash (make-string 1000001  #\nul) 10 1))))
)

;;

(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))) ) ) )

;;

(cond-expand
  (compiling
    (import (chicken gc))

    (define-constant WEAK-DATA-SIZE 12)
    (assert (zero? (modulo WEAK-DATA-SIZE 4)))

    (define (list-split ls #!optional (n (floor (/ (length ls) 2))))
      (let loop ((n n) (hds '()) (tls ls))
        (if (<= n 0) (values (reverse hds) tls)
            (loop (sub1 n) (cons (car tls) hds) (cdr tls)) ) ) )

    (define (drop ls n) (receive (_ ns) (list-split ls n) ns))

    #|
    (define gensym!)
    (let ((+counter+ -1))
      (set! gensym!
        (lambda (#!optional (pre "g!"))
          (set! +counter+ (add1 +counter+))
          (string->symbol (string-append (if (symbol? pre) (symbol->string pre) pre)
                                         (number->string +counter+))) ) ) )
    |#

    (define (gensyms n #!optional (seed 'g))
      (let loop ((n n) (l '()))
        (if (not (positive? n)) (reverse l)
            (loop (sub1 n) (cons (gensym seed) l))) ) )

    (define (gen-symkeys-data #!optional (tag 'wks) (siz WEAK-DATA-SIZE))
      (gensyms siz tag) )

    (define (split-size m #!optional (n 2)) (round (/ m n)))
    (define (split-length ls #!optional (n 2)) (split-size (length ls) n))

    (define (symkeys-split ls #!optional (n (split-length ls)))
      (receive (hds tls) (list-split ls n)
        (values (map symbol->string hds) tls) ) )

    (test-group "HT - weak eq? hash-table - keys"
      ;make weak key table , gensym keys , set! table keys ,
      ;convert some keys to strings , gc (converted symbols keys -> bwp) ,
      ;verify the bwp keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #f))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                     ;drop some keys, but save for resurrection, as strings,
                     ;not symbols
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (symkeys-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;resurrect for probe
            (for-each
              (lambda (x) (test-assert (not (hash-table-exists? ht (string->symbol x)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak eq? hash-table - values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #f #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (test (length keys) (length vals))
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length rst) (split-size WEAK-DATA-SIZE))
          ;(test (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht b)))) bwps)
            (for-each (lambda (k) (test-assert (hash-table-exists? ht k))) tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak eq? hash-table - key+values"
      ;make weak value table , gensym keys & values , set! table keys & values ,
      ;drop some values (keeping the symbol keys) , gc (dropped values -> bwp) ,
      ;verify the bwp valued keys are not in the table , verify the remaining symbol
      ;keys are in the table
      (let* ((ht (make-hash-table eq? #:weak-keys #t #:weak-values #t))
             (keys (gen-symkeys-data 'wky))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop 1st 1/4 values (keep keys) & 2nd 1/4 keys (keep values)
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen))
                      ((bwps tls) (symkeys-split tls slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged"
            (for-each (lambda (h) (test-assert (not (hash-table-exists? ht h)))) hds)
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht (string->symbol b)))))
                      bwps)
          ) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
                    keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - keys"
      ;string keys w/ string values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #f))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some keys, but save for resurrection
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! bwps (map string->symbol bwps))
          (set! keys tls)
          (gc #t)
          (test-group "table scavanged"
            ;probe remainder
            (for-each
              (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
              bwps)
          )
          ;for common end test
          (set! vals rst) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #f #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop some values
        (let*-values (((_ rst) (list-split vals slen))
                      ((bwps tls) (list-split keys slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          ;(test (length tls) (length rst))
          (set! vals rst)
          (gc #t)
          (test-group "table scavanged (clean!)"
            (hash-table-clean! ht)
            (test (length tls) (hash-table-size ht))
            (test (hash-table-size ht) (length (hash-table->alist ht)))
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht b)))) bwps)
            (for-each (lambda (k) (test-assert (hash-table-exists? ht k))) tls)
          )
          ;for common end test
          (set! keys tls) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
          (test (length keys) (hash-table-size ht))
        ) )
    )

    (test-group "HT - weak string=? hash-table - key+values"
      ;string keys w/ symbol values
      (let* ((ht (make-hash-table string=? #:weak-keys #t #:weak-values #t))
             (keys (map symbol->string (gen-symkeys-data 'wky)))
             (vals (gen-symkeys-data))
             (slen (split-length vals 4)) )
        (test-group "table build"
          (for-each (lambda (k v) (hash-table-set! ht k v)) keys vals)
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k)))) keys vals)
        )
                       ;drop 1st 1/3 values & 2nd 1/3 keys
        (let*-values (((_ rst) (list-split vals slen))
                      ((hds tls) (list-split keys slen)) ;hds killed
                      ((bwps tls) (list-split tls slen)) )
          ;(test (length tls) (split-size WEAK-DATA-SIZE))
          (set! keys tls)
          (set! vals rst)
          (set! bwps (map string->symbol bwps)) ;kill keys
          (gc #t)
          (test-group "table scavanged"
            (for-each (lambda (h) (test-assert (not (hash-table-exists? ht h)))) hds)
            (for-each (lambda (b) (test-assert (not (hash-table-exists? ht (symbol->string b)))))
                      bwps)
          ) )
        (test-group "table remainder"
          (for-each (lambda (k v) (test-assert (eq? v (hash-table-ref ht k))))
                    keys (drop vals slen))
          (test (length keys) (hash-table-size ht))
        ) )
    )
  )
  (else) )

;;