; FILE          "general-table.scm"
; IMLEMENTS     simple parameterized hash tables
; AUTHOR        Ken Dickey
; DATE          1994 April 17
; LAST UPDATE   1994 April 21  -- misc. cleanup
        
; NOTES         Procedural version.  Heavily influenced by JAReese and
;                       Kelsey's S48 version and YASOS collections.

; This is expository code in raw IEEE Scheme without macros or records. 

; lightly tested.  Bugs & fixes to KenD@Newton.Apple.com


;; INTERFACE:

;  (make-table)         -> <table>  keyed on objects
;  (make-string-table)  -> <table>  keyed on strings
;  (make-symbol-table)  -> <table>  keyed on symbols
;  (table? obj) -> #t or #f
;  (table-associate! table key value) -> <key>                                                                  
;  (table-lookup table key failure-marker) -> <value> or failure-marker
;     Failure-marker allows for #f values.
;     Eg: (let* ( (fail (cons #f #f)) ; not eq? to anything else
;                 (probe (table-lookup foo-table my-key fail)) )
;           (if (eq? probe fail) <failure case> <success case>)
;                          
;  (table-remove! table key) -> <value> ; removes key,value pair
;     An error is signalled if key is not present
;  (table-size table) -> <number of key,value pairs in table
;  (table-for-each table proc) ; proc on 1 arg applied to 
;     each key,value pair.
;  (make-table-maker compare-fun hash-fun) -> <table-maker-proc>
;     Eg: (define (make-symbol-table) 
;             (make-general-table-maker eq? hash-symbol))

; These can be put somewhere else:
;  (hash-symbol sym  n) -> 0..n-1
;  (hash-string str  n) -> 0..n-1
;  (hash-number int  n) -> 0..n-1
;  (hash-char   char n) -> 0..n-1
;  (hash-vector vec  n) -> 0..n-1
;  (hash-object obj  n) -> 0..n-1


;; DESIGN NOTES

; A table is a record, one of whose slots is a vector of alists.  Each
; slot in the vector is a hash bucket.  Initially there is only one
; bucket, so the table is just a fancy alist.  As the table grows, the
; number of buckets is increased and the table rehashed.  The growth
; criteria and hashing functions are fairly simple minded.  Tables are
; vectors which are huge and ugly when printed.  You probably want to use
; a true record or OO version of this code rather than this expository
; version.


;; TABLE FUNCTIONS (def'ed in inner scope)

(define table?              'bogus) 
(define table-lookup        'bogus)     
(define table-associate!    'bogus)     
(define table-remove!       'bogus)     
(define table-size          'bogus)     
(define table-for-each      'bogus)     


(define (MAKE-GENERAL-TABLE-MAKER compare?-fun hash-fun)

  (define (MAKE-ASSOC compare-fn) 
    ; memoize assoc-funs to save space
    (letrec ( (assoc-alist 
               (list (cons eq?    assq) 
                     (cons eqv?   assv) 
                     (cons equal? assoc)))
              (really-make-assoc 
                (lambda (match?)
                   (lambda (key alist)
                      (let loop ( (alist alist) )
                        (cond
                         ((null? alist) #f)
                         ((match? key (caar alist)) (car alist))
                         (else (loop (cdr alist))))))))
            )
      (cond 
        ((assq compare-fn assoc-alist) => cdr)
        (else (set! assoc-alist 
                      (cons (cons compare-fn (really-make-assoc compare-fn)) 
                                 assoc-alist))))
  ) ) ; end make-assoc
  
  (define (MAKE-TABLE-HASH hash-fun)  ; internalize hash-fun
    (lambda (table obj)
      (let ( (num-buckets (tr-num-buckets table)) )
        (if (= 1 num-buckets)
            0
            (hash-fun obj num-buckets))
  ) ) )
  
  (define MAX-TABLE-BUCKETS 10000) ; your milage may vary
  
  (define (GROW-TABLE! table)
    (let* ( (old-num-buckets (tr-num-buckets table))
            (new-num-buckets 
                (if (= old-num-buckets 1)
                    23
                    (+ 1 (* 3 old-num-buckets)))) ; should be relative prime
          )
      (tr-grow-size-set! table (* new-num-buckets 10)) ;; N.B.: untuned
      (if (< new-num-buckets max-table-buckets)
        ; rehash
        (let ( (old-data (tr-data table)) )
                (tr-data-set! table (make-vector new-num-buckets '()))
                ; walk old data
            (let loop ( (index (- (vector-length old-data) 1)) )
               (for-each (lambda (bucket) 
                             (associate! table (car bucket) (cdr bucket)))
                         (vector-ref old-data index))
                   (if (> index 0)
                       (loop (- index 1))
                       table)
      ) )  )
  ) )


  ;; TABLE "RECORDS"
  
  (define TR-MARKER "table"
  )
  (define (TR? tr)
        (and (vector? tr)
             (= (vector-length tr) 7)
                 (eq? tr-marker (vector-ref tr 0)))
  )
  (define (MAKE-TABLE-RECORD compare? assoc-fn hash-fn)
        ;       0     1 2   3       4        5        6
    (vector tr-marker 0 50 compare? assoc-fn hash-fn (vector '()))
  )
  (define (TR-SIZE tr)                  (vector-ref tr 1)
  )
  (define (TR-GROW-SIZE tr)             (vector-ref tr 2)
  )
  (define (TR-COMPARE tr)               (vector-ref tr 3)
  )
  (define (TR-ASSOC tr)                 (vector-ref tr 4)
  )
  (define (TR-HASH tr)                  (vector-ref tr 5)
  )
  (define (TR-DATA tr)                  (vector-ref tr 6) ; vector of buckets
  )
  (define (TR-NUM-BUCKETS tr) (vector-length (tr-data tr))
  )
  (define (TR-SIZE-SET! tr new-size)
         (vector-set! tr 1 new-size)
  )
  (define (TR-GROW-SIZE-SET! tr new-size)
         (vector-set! tr 2 new-size)
  )
  (define (TR-DATA-SET! tr new-data)
         (vector-set! tr 6 new-data)
  )
  (define (TR-DATA-BUCKET tr bucket-index) 
        (vector-ref (tr-data tr) bucket-index) ; zero based
  )
  (define (TR-DATA-BUCKET-SET! tr bucket-index new-alist)
        (vector-set! (tr-data tr) bucket-index new-alist)
  )
  
  
  ;; EXPORTED FUNCTIONS
  
  (define (LOOKUP table key failure-marker)
        (cond 
            (((tr-assoc table) 
              key 
              (tr-data-bucket table ((tr-hash table) table key)))
                  => cdr)
            (else failure-marker))
  )
  (define (ASSOCIATE! table key value)
    (let* ( (index ((tr-hash table) table key))
            (alist (tr-data-bucket table index)) 
          )
      (cond
        (((tr-assoc table) key alist) 
          => (lambda (bucket) (set-cdr! bucket value) key))
        (else 
           (tr-data-bucket-set! table index (cons (cons key value) alist))
           (tr-size-set! table (+ 1 (tr-size table)))
           (if (> (tr-size table) (tr-grow-size table))
               (grow-table! table))
           key))
  ) )
  (define (REMOVE! table key) ;; returns old value
    (let* ( (index ((tr-hash table) table key))
            (alist (tr-data-bucket table index))
            (match? (tr-compare table)) 
          )
       (cond 
         ; empty alist?
         ((null? alist) (error "TABLE:REMOVE! Key not found: " key))
         ; 1st bucket in alist?
         ((match? key (caar alist))
          (let ( (value (cdar alist)) )
             (tr-data-bucket-set! table index (cdr alist))
             (tr-size-set! table (- (tr-size table) 1))
             value)
         )
         ; general case
         (else
           (let loop ( (last alist) (this (cdr alist)) )
             (cond
               ((null? this) (error "TABLE:REMOVE! Key not found: " key))
               ((match? key (caar this))
                (let ( (value (cdar this)) )
                  (set-cdr! last (cdr this))
                  (tr-size-set! table (- (tr-size table) 1))
                 value)
               )
               (else
                (loop (cdr last) (cdr this)))
         ) ) )
      ))
  )
  (define (WALK table proc)
    (let loop ( (index (- (tr-num-buckets tr) 1)) )
        (for-each proc (tr-data-bucket table index))
        (if (> index 0)
                (loop (- index 1))
                'done)
  ) )

  (set! table-for-each          walk)
  (set! table-associate!        associate!)
  (set! table-remove!           remove!)
  (set! table-size              tr-size)
  (set! table-lookup            lookup)
  (set! table?                  tr?)

  (lambda () ; make-general-table-maker
      (make-table-record compare?-fun
                         (make-assoc compare?-fun) 
                         (make-table-hash hash-fun))
) )

;------------------------------------------------------------------v
; simple hash functions from "proplist.scm" (c) 1991, Marc Feeley

(define (HASH-SYMBOL sym n)
  (hash-string (symbol->string sym) n))

(define (HASH-STRING str n)
  (let ((len (string-length str)))
    (let loop ((h 0) (i (- len 1)))
      (if (>= i 0)
        (let ((x (+ (* h 256) (char->integer (string-ref str i)))))
          (loop (modulo x n) (- i 1)))
        h))))

(define (HASH-NUMBER num n)
  (modulo
    (inexact->exact
      (floor
        (cond ((integer? num)  num)
              ((rational? num) (+ (numerator num) (denominator num)))
              ((real? num)     num)
              (else            (+ (real-part num) (imag-part num))))))
  n))

(define (HASH-CHAR chr n)
  (modulo (char->integer chr) n))

(define (HASH-VECTOR vec n)
  (modulo (vector-length vec) n))

(define (HASH-OBJECT obj n)
  (cond ((symbol? obj)      (hash-symbol obj n))
        ((string? obj)      (hash-string obj n))
        ((number? obj)      (hash-number obj n))
        ((char? obj)        (hash-char obj n))
        ((vector? obj)      (hash-vector obj n))
        ((pair? obj)        0)
        (else               (modulo 1 n))))


;------------------------------------------------------------------^


(define MAKE-TABLE         (make-general-table-maker eq?      hash-object))
(define MAKE-STRING-TABLE  (make-general-table-maker string=? hash-string))
(define MAKE-SYMBOL-TABLE  (make-general-table-maker eq?      hash-symbol))


;;                           --- E O F ---