; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009,2010
; See the LICENSE file of the S9fES package for terms of use
;
; (make-hash-table)                               ==>  hash-table
; (make-hash-table integer)                       ==>  hash-table
; (hash-table-length hash-table)                  ==>  integer
; (hash-table-ref hash-table object)              ==>  value | #f
; (hash-table-set! hash-table object-k object-v)  ==>  unspecific
; (hash-table->list hash-table)                   ==>  list
;
; MAKE-HASH-TABLE creates a fresh hash table. When a size is
; passed to it, the given number of slots will be created in
; the table, otherwise a built-in default is used.
; No matter what size is specified, the hash table will grow
; automatically when the number of elements stored in it
; exceeds its current size. When specifying an explicit size,
; it should be a prime number.
;
; HASH-TABLE-LENGTH returns the number of objects currently
; stored in the given hash table.
;
; HASH-TABLE-REF retrieves a VALUE from a hash table using the
; given OBJECT as key. It returns the value as the only element
; of a fresh list. When no element with the given key exists,
; it returns #F.
;
; HASH-TABLE-SET! stores the value OBJECT-V under the key
; OBJECT-K in the given hash-table.
;
; HASH-TABLE->LIST returns a list containing all pairs of
; the given hash table in no specific order.
;
; Example:   (let ((h (make-hash-table)))
;              (hash-table-set! h "key" 'value)
;              (hash-table-ref  h "key"))
;                                          ==>  (value)

(load-from-library "count.scm")

(define (make-hash-table . size)
  (if (and (pair? size)
           (not (null? (cdr size))))
      (error "make-hash-table: too many arguments" size))
  (let* ((size (if (null? size)
                  101
                  (car size)))
         (h    (make-vector size '())))
    (cons 0 h)))

(define (hash x k)
  (letrec
    ((string->hash
       (lambda (s k)
         (let ((ks (string-length s)))
           (let loop ((h 0)
                      (i 0))
             (if (>= i ks)
                 h
                 (loop (remainder
                         (+ (* 8 h) (char->integer (string-ref s i)))
                         k)
                       (+ 1 i))))))))
    (cond ((symbol? x) (string->hash (symbol->string x) k))
          ((string? x) (string->hash x k))
          ((number? x) (remainder (abs x) k))
          ((char? x)   (remainder (char->integer x) k))
          ((pair? x)   (remainder (count x) k))
          ((vector? x) (remainder (count (vector->list x)) k))
          (else        (- k 1)))))

(define hash-table-ref
  (let ((hash hash))
    (lambda (h k)
      (let ((i (hash k (vector-length (cdr h)))))
        (cond ((assoc k (vector-ref (cdr h) i))
                => (lambda (x)
                     (cons (cdr x) '())))
              (else
                #f))))))

(define (grow-table! h)
  (if (< (vector-length (cdr h)) 9973)
      (let* ((k  (vector-length (cdr h)))
             (k  (cond ((< k  499)   499)
                       ((< k 4999)  4999)
                       ((< k 9973)  9973)
                       (else       19997)))
             (h* (cons (car h) (make-vector k '()))))
        (let loop ((i 0)
                   (k (vector-length (cdr h))))
          (cond ((>= i k)
                  (set-cdr! h (cdr h*)))
                (else
                  (for-each (lambda (x)
                              (hash-table-set! h* (car x) (cdr x)))
                            (vector-ref (cdr h) i))
                  (loop (+ 1 i) k)))))))

(define hash-table-set!
  (let ((hash        hash)
        (grow-table! grow-table!))
    (lambda (h k v)
      (if (> (car h) (vector-length (cdr h)))
          (grow-table! h))
      (let ((i (hash k (vector-length (cdr h)))))
        (cond ((assoc k (vector-ref (cdr h) i))
                => (lambda (x)
                     (set-cdr! x v)))
              (else
                (set-car! h (+ 1 (car h)))
                (vector-set! (cdr h)
                             i
                             (cons (cons k v)
                                   (vector-ref (cdr h) i)))))))))

(define hash-table-length car)

(define (hash-table->list h)
  (apply append (vector->list (cdr h))))
