Hash tables

Location: lib, 124 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009-2012
; Placed in the Public Domain
;
; (make-hash-table <option> ...)                  ==>  hash-table
; (alist->hash-table alist)                       ==>  hash-table
; (alist->hash-table alist integer)               ==>  hash-table
; (hash-table-length hash-table)                  ==>  integer
; (hash-table-ref hash-table object)              ==>  value | #f
; (hash-table-remove! hash-table object)          ==>  value | #f
; (hash-table-set! hash-table object-k object-v)  ==>  unspecific
; (hash-table->alist hash-table)                  ==>  list
;
; (load-from-library "hash-table.scm")
;
; MAKE-HASH-TABLE creates a fresh hash table.
;
; When the 'SIZE option is passed to it, it must be followed by
; an integer specifying its initial number of slots. When no
; initial value is specified, a built-in default will be 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.
;
; When the 'TEST option is passed to MAKE-HASH-TABLE, it must
; be followed by a predicate testing for the identity of keys.
; The predicate defaults to EQUAL?, but a more specific and/or
; more efficient predicate can be used when keys are limited to
; the domain of such a predicate.
;
; ALIST->HASH-TABLE creates a fresh hash table and inserts each
; cdr element of the given ALIST into that table using the
; associated car element as a key. It returns the new hash table.
; When an additional INTEGER is passed to ALIST->HASH-TABLE, an
; initial table of the given size will be allocated. The INTEGER
; 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-REMOVE! removes the key OBJECT (and its associated
; value) from the given hash table.
;
; HASH-TABLE-SET! stores the value OBJECT-V under the key
; OBJECT-K in the given hash-table.
;
; HASH-TABLE->ALIST returns an association 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")
(load-from-library "assp.scm")
(load-from-library "keyword-value.scm")
(load-from-library "define-structure.scm")

(define-structure ht (len 0) (test equal?) table)

(define make-hash-table
  (let ((make-ht       make-ht)
        (ht-set-test!  ht-set-test!)
        (ht-set-table! ht-set-table!))
    (lambda opts
      (accept-keywords "make-hash-table" opts '(test size))
      (let ((size (keyword-value opts 'size 101))
            (test (keyword-value opts 'test equal?)))
        (let ((ht (make-ht)))
          (ht-set-test! ht test)
          (ht-set-table! ht (make-vector size '()))
          ht)))))

(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)
        (ht-test ht-test))
    (lambda (h k)
      (let ((i (hash k (vector-length (ht-table h)))))
        (cond ((assp (ht-test h) k (vector-ref (ht-table h) i))
                => (lambda (x)
                     (cons (cdr x) '())))
              (else
                #f))))))

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

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

(define hash-table-remove!
  (let ((hash     hash)
        (ht-test  ht-test)
        (ht-table ht-table))
    (lambda (h k)
      (let* ((i   (hash k (vector-length (ht-table h))))
             (new (let rem ((v* (vector-ref (ht-table h) i)))
                    (cond ((null? v*)
                            '())
                          (((ht-test h) k (caar v*))
                            (ht-set-len! h (- (ht-len h) 1))
                            (cdr v*))
                          (else
                            (cons (car v*)
                                  (rem (cdr v*))))))))
        (vector-set! (ht-table h) i new)))))

(define hash-table-length ht-len)

(define (alist->hash-table alist . opts)
  (let ((h (apply make-hash-table opts)))
    (for-each (lambda (x)
                (hash-table-set! h (car x) (cdr x)))
              alist)
    h))

(define hash-table->alist
  (let ((ht-table ht-table))
    (lambda (h)
      (apply append (vector->list (ht-table h))))))

contact  |  privacy