
(export (equal-hash string=-hash string=-ci-hash char=-hash char=-ci-hash =-hash make-table table? table-ref table-set! table-remove! table-size table-walk)


(define (make-table . args)
"([initial-size {comparison-fn hash-fn}]) Make a new hash table with room initially for INITIAL-SIZE entries, using the given COMPARISON-FN and HASH-FN.  INITIAL-SIZE defaults to something reasonably small.  COMPARISON-FN and HASH-FN default to EQV? and EQV-HASH."
(let* ((len (length args))
    (initial-size
    (if (>= len 1)
    (max (car args) 2)
 17))
 (comparison-fn
 (if (>= len 2)
(cadr args)
eqv?))
 (hash-fn
 (if (>= len 3)
(caddr args)
eqv-hash)))
(when (= len 2)
(error 'make-table args "a COMPARISON-FN was specified but not a HASH-FN"))
(when (> len 4)
(error 'make-table args "Too many arguments"))

(make-table-rep initial-size comparison-fn hash-fn)))

(define (table? object)
"Is OBJECT a table?"
(table-rep? object))

(define (table-ref table key)
"Fetch the value stored under KEY in TABLE, returning #F if KEY has no entry in TABLE."
(let ((index (find-table-rep-index table key))
   (vec (table-rep-vector table))
(compare? (table-rep-comparison-fn table)))
(let loop ((entries (vector-ref vec index)))
(cond
((null? entries)		; Not found
#f)
((compare? (caar entries) key)	; This is it
(cdar entries))
(else
(loop (cdr entries)))))))

(define (table-set! table key value)
"Either change the current entry for KEY in TABLE to VALUE, if such an entry exists, or add an entry mapping KEY to VALUE."
(let* ((index (find-table-rep-index table key))
    (vec (table-rep-vector table))
 (compare? (table-rep-comparison-fn table))
 (entries (vector-ref vec index)))
(let loop ((ls entries))
(cond
((null? ls)			; Not found
(let ((new-entry (cons key value)))
(vector-set! vec index (cons new-entry entries))
(set-table-rep-size! table (+ (table-rep-size table) 1))
(if (>= (table-rep-size table)
     (table-rep-max-size table))
(rehash-table! table))))
((compare? (caar ls) key)	; This is it
(set-cdr! (car ls) value))
(else
(loop (cdr ls)))))))

(define (table-remove! table key)
"Remove the entry for KEY from TABLE, if such an entry exists.  Return a boolean indicating whether or not the entry existed."
(let ((index (find-table-rep-index table key))
   (vec (table-rep-vector table))
(compare? (table-rep-comparison-fn table)))
(let loop ((entries (vector-ref vec index))
        (lag #f))
(cond
((null? entries)		; Not found
#f)
((compare? (caar entries) key)	; This is it
(if (not lag)
(vector-set! vec index (cdr entries))
(set-cdr! lag (cdr entries)))
(set-table-rep-size! table (- (table-rep-size table) 1))
#t)
(else
(loop (cdr entries) entries))))))

(define (table-size table)
"How many entries are there in TABLE?"
(table-rep-size table))

(define (table-walk fn table)
"Apply FN to the key and value for each entry in TABLE.  No changes should be made to the TABLE during the walk."
(let ((vec (table-rep-vector table))
   (max-size (table-rep-max-size table)))
(let loop ((index 0))
(when (< index max-size)
(for-each (lambda (entry)
          (fn (car entry) (cdr entry)))
    (vector-ref vec index))
(loop (+ index 1))))))


; (define eq-hash ...)	; primitive

; (define eqv-hash ...)	; primitive

(define (equal-hash object)
(cond
((string? object)
(string=-hash object))
((vector? object)
(let ((len (vector-length object)))
(let loop ((index 0)
        (hash 0))
(if (< index len)
(loop (+ index 1)
   (logxor hash (equal-hash (vector-ref object index))))
hash))))
((pair? object)
(let loop ((tail (cdr object))
        (hash (logxor -1 (equal-hash (car object)))))
(if (pair? tail)
(loop (cdr tail)
   (logxor hash (equal-hash (car tail))))
(logxor hash (equal-hash tail)))))
(else
(eqv-hash object))))

(define (string=-hash s)
(let ((len (string-length s)))
(let loop ((index 0)
        (hash -2))
(if (< index len)
(loop (+ index 1)
   (logxor hash (char=-hash (string-ref s index))))
hash))))

(define (string=-ci-hash s)
(let ((len (string-length s)))
(let loop ((index 0)
        (hash -2))
(if (< index len)
(loop (+ index 1)
   (logxor hash (char=-ci-hash (string-ref s index))))
hash))))

(define char=-hash eqv-hash)

(define (char=-ci-hash c) 
(eqv-hash (char-downcase c)))

(define =-hash eqv-hash)


(define (find-table-rep-index table key)
(let ((hash-fn (table-rep-hash-fn table))
   (mod (table-rep-max-size table)))
(modulo (hash-fn key) mod)))

(define (rehash-table! table)
(let* ((old-vec (table-rep-vector table))
    (old-max-size (table-rep-max-size table))
 (new-max-size (* old-max-size 2))
 (new-vec (make-vector new-max-size))
 (hash-fn (table-rep-hash-fn table)))
(let loop ((index 0))
(when (< index old-max-size)
(for-each (lambda (entry)
          (let ((i (modulo (hash-fn (car entry))
                        new-max-size)))
       (vector-set! new-vec i
                 (cons entry
                    (vector-ref new-vec i)))))
 (vector-ref old-vec index))
(loop (+ index 1))))

(set-table-rep-vector! table new-vec)
(set-table-rep-max-size! table new-max-size)))

(define tr-descriptor #f)
(define (print-table port table display?)
(format port "#<Table @ ~S>" (eq-hash table)))

(define make-full-table-rep #f)
(define (make-table-rep max-size comparison-fn hash-fn)
(make-full-table-rep max-size comparison-fn hash-fn
(make-vector max-size '())
0))
(define table-rep? #f)

(define table-rep-max-size #f)
(define table-rep-comparison-fn #f)
(define table-rep-hash-fn #f)
(define table-rep-vector #f)
(define table-rep-size #f)

(define set-table-rep-max-size! #f)
(define set-table-rep-vector! #f)
(define set-table-rep-size! #f)


(set! tr-descriptor
(make-record-type 'table-rep
'(max-size comparison-fn hash-fn vector size)
#f
print-table))

(set! make-full-table-rep (record-constructor tr-descriptor))
(set! table-rep? (record-predicate tr-descriptor))

(set! table-rep-max-size (record-accessor tr-descriptor 'max-size))
(set! table-rep-comparison-fn
(record-accessor tr-descriptor 'comparison-fn))
(set! table-rep-hash-fn (record-accessor tr-descriptor 'hash-fn))
(set! table-rep-vector (record-accessor tr-descriptor 'vector))
(set! table-rep-size (record-accessor tr-descriptor 'size))

(set! set-table-rep-max-size! (record-updater tr-descriptor 'max-size))
(set! set-table-rep-vector! (record-updater tr-descriptor 'vector))
(set! set-table-rep-size! (record-updater tr-descriptor 'size))
)
   t  
;;; Tables.scheme
;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.
;;; Last changed by Pavel on March 22, 1989 6:47:43 pm PST
;;; Michael Plass, January 21, 1989 0:25:52 am PST
;;; Exported interface
;;; Predefined hashing-functions
;;; Implementation
;; NB: Be sure to change rehash-table! to match
;;	any changes in this definition!!
 Êg  –(cedarcode) style•NewlineDelimiter
™ ™JšœÑertœ=™LJ™:J™2—J˜ ˜œJ˜ ™J˜ ˜J˜ˆ˜˜˜˜J˜——˜˜J˜J˜——˜	˜J˜J˜———˜J˜K—˜J˜.—J˜ J˜5——J˜ ˜J˜J˜—J˜ ˜J˜W˜.˜!J˜+—˜,˜˜J˜—˜+J˜—˜J˜—————J˜ ˜$J˜{˜/˜"J˜+J˜"—˜˜˜˜#J˜0J˜8˜J˜ J˜———˜&J˜—˜J˜—————J˜ ˜!J˜~˜.˜!J˜+—˜+J˜˜˜J˜—˜+˜J˜%J˜—J˜8J˜—˜J˜!—————J˜ ˜J˜&J˜—J˜ ˜J˜q˜$J˜)˜˜˜˜'J˜——J˜—————J˜ ™ J˜ J˜"J˜ J˜#J˜ ˜˜˜J˜—˜˜#˜J˜˜˜J˜8—J˜————˜˜J˜5˜˜J˜)—J˜"———˜J˜———J˜ ˜˜˜J˜˜˜J˜3—J˜————J˜ ˜˜˜J˜˜˜J˜6—J˜————J˜ J˜J˜ ˜J˜—J˜ J˜—J˜ ™J˜ ˜(JšÏbœžœž	™/Jšœž ™#˜)J˜$J˜——J˜ ˜˜)˜-J˜"J˜%J˜%—˜˜˜˜0˜'˜˜J˜.——J˜———J˜——J˜ J˜%J˜.——J˜ J˜˜)J˜.—J˜ J˜˜7˜3J˜J˜——J˜J˜ J˜J˜#J˜J˜J˜J˜ J˜#J˜!J˜J˜ J˜ ˜˜J˜-J˜J˜——J˜ J˜=J˜2J˜ J˜C˜J˜/—J˜AJ˜?J˜;J˜ J˜GJ˜CJ˜?—J˜—— …—    à  »  