; FILE           "general-table.scm"
; IMLEMENTS      simple parameterized hash tables
; AUTHOR         Ken Dickey
; DATE          1994 April 21
; LAST UPDATE   1994 April 22
        
; NOTES         OO style (requires YASOS) 
;  lightly tested.  Bugs & fixes to KenD@Newton.Apple.com

;(require 'yasos)



;; 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
;  (associate! table key value) -> <key>
;  (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 (lookup foo-table my-key fail)) )
;           (if (eq? probe fail) <failure case> <success case>)
;                          
;  (remove! table key) -> <value> ; removes key,value pair
;     An error is signalled if key is not present
;  (size table) -> <number of key,value pairs in table
;  (walk table proc) ; proc on 1 arg applied to 
;     each key,value pair.
;  (make-general-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

;-------------------------
;; HASH TABLE 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.  


;; you may need the following: when unless while add1 sub1

;(define-syntax WHEN
;     (syntax-rules ()
;        ((when <condition> <body> ...)
;         ;; =>
;         (if <condition> (begin <body> ...) #f))
;)  )

;(define-syntax UNLESS
;     (syntax-rules ()
;        ((unless <condition> <body> ...)
;         ;; =>
;         (if <condition> #f (begin <body> ...)))
;)  )

;(define-syntax WHILE
;     (syntax-rules ()
;        ((while <condition> <body> ...)
;         ;; =>
;         (let ( (test (lambda () <condition>)) )
;           (let recur ( (c (test)) )
;             (when c
;                 <body> ...
;                  (recur (test)))
;         ) )
;)  )  )

;(define (ADD1 n) (+ n 1))
;(define (SUB1 n) (- n 1))



;; TABLE FUNCTIONS (def'ed in collect.oo -- uncomment if not loaded)

;(define-predicate TABLE?)
;(define-operation (LOOKUP table key failure-object))
;(define-operation (ASSOCIATE! table key value)) ;; returns key
;(define-operation (REMOVE! table key))          ;; returns value

(define-operation (WALK table proc)) ; not in collect.oo


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

  ;; TABLE RECORDS {locally scoped generic operations}
  
  (define-predicate        table-record?)
  (define-operation        (increment-size! self))
  (define-operation        (decrement-size! self))
  (define-access-operation grow-size)
  (define-operation        (compare-fun self))
  (define-operation        (assoc-fun self))
  (define-operation        (hash-fun self))
  (define-access-operation data)
  (define-operation        (num-buckets self))
  (define-access-operation data-bucket)
  (define-operation        (zero! self))

  (define (MAKE-TABLE-RECORD compare? assoc-fn hash-fn)
    (let ( (num-pairs 0)
           (grow-when 20)
           (my-data (vector '()))
         )
      (object 
         ((table-record? self) #t)
         ((size self) num-pairs)
         ((zero! self) (set! num-pairs 0))
         ((increment-size! self) (set! num-pairs (add1 num-pairs)))
         ((decrement-size! self) (set! num-pairs (sub1 num-pairs)))
         ((grow-size self) grow-when)
         (((setter grow-size) self new-size) 
          (set! grow-when new-size))
         ((compare-fun self) compare?)
         ((assoc-fun self)   assoc-fn)
         ((hash-fun self)    hash-fn)
         ((num-buckets self) (vector-length my-data))
         ((data self) my-data)
         (((setter data) self new-data) (set! my-data new-data))
         ((data-bucket self index) (vector-ref my-data index))
         (((setter data-bucket) self index new-data) 
           (vector-set! my-data index new-data)
           self)    
  ) ) )
  
  (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-record obj)
      (let ( (number-of-buckets (num-buckets table-record)) )
        (if (= 1 number-of-buckets)
            0
            (hash-fun obj number-of-buckets))
  ) ) )
  
  (define MAX-TABLE-BUCKETS 10000) ; your milage may vary
  
  (define (GROW-TABLE! table-obj table-record)
    (let* ( (old-num-buckets (num-buckets table-record))
            (new-num-buckets 
                (if (= old-num-buckets 1)
                    23
                    (+ 1 (* 3 old-num-buckets)))) ; should be relative prime
          )
      (set (grow-size table-record) (* new-num-buckets 10)) ;; N.B.: untuned
      (when (< new-num-buckets max-table-buckets)
        ; rehash
        (let ( (old-data (data table-record)) )
          (set (data table-record) (make-vector new-num-buckets '()))
          (zero! table-record) ; associate! adds to size
          ; walk old data
          (let loop ( (index (sub1 (vector-length old-data))) )
            (for-each (lambda (bucket) 
                        (associate! table-obj (car bucket) (cdr bucket)))
                      (vector-ref old-data index))
            (if (> index 0)
              (loop (sub1 index))
              table-obj)
      ) )  )
  ) )


  (lambda () ; make-general-table-maker
    (let ( (table
              (make-table-record compare?-proc
                                 (make-assoc compare?-proc) 
                                 (make-table-hash hash-proc)))
         )
      (object
        ;; table behaviors
        ((TABLE? self) #t)
        ((SIZE self) (size table))
        ((PRINT self port) (format port "#<Table>"))
        ((LOOKUP self key failure-marker)
             (cond 
              (((assoc-fun table) 
               key 
               (data-bucket table ((hash-fun table) table key)))
                    => cdr)
              (else failure-marker))
             )
        ((ASSOCIATE! self key value)
         (let* ( (index ((hash-fun table) table key))
                 (alist (data-bucket table index)) 
               )
           (cond
            (((assoc-fun table) key alist) 
             => (lambda (bucket) (set-cdr! bucket value) key))
            (else 
             (set (data-bucket table index) (cons (cons key value) alist))
             (increment-size! table)
             (if (> (size table) (grow-size table))
               (grow-table! self table))
             key))
           ) )
        ((REMOVE! self key) ;; returns old value
         (let* ( (index ((hash-fun table) table key))
                 (alist (data-bucket table index))
                 (match? (compare-fun 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)) )
               (set (data-bucket table index) (cdr alist))
               (decrement-size! table)
               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))
                   (decrement-size! table)
                   value)
                 )
                (else
                 (loop (cdr last) (cdr this)))
                ) ) )
            )) )
        ((WALK self proc)
         (let loop ( (index (sub1 (num-buckets table))) )
           (for-each proc (data-bucket table index))
           (if (> index 0)
             (loop (sub1 index))
             'done))
         )
        ;; collection behaviors
        ((COLLECTION? self) #t)
        ((GEN-KEYS self) ; lazy
         (let* ( (bucket-index (sub1 (num-buckets table)))
                 (alist (data-bucket table bucket-index))
               )
           (lambda ()
             (while (null? alist)
               (when (zero? bucket-index)
                 (error "gen-keys: more keys asked for than available!"))
               (set! bucket-index (sub1 bucket-index))
               (set! alist (data-bucket table bucket-index)))
             (let ( (key (caar alist)) )
               (set! alist (cdr alist))
               key)))
        )
        ((GEN-ELTS self) ; lazy
         (let* ( (bucket-index (sub1 (num-buckets table)))
                 (alist (data-bucket table bucket-index))
               )
           (lambda ()
             (while (null? alist)
               (when (zero? bucket-index)
                 (error "gen-keys: more keys asked for than available!"))
               (set! bucket-index (sub1 bucket-index))
               (set! alist (data-bucket table bucket-index)))
             (let ( (elt (cdar alist)) )
               (set! alist (cdr alist))
               elt)))
        )
        ((FOR-EACH-KEY self proc)
         (walk table (lambda (bucket) (proc (car bucket))))
         )
        ((FOR-EACH-ELT self proc)
         (walk table (lambda (bucket) (proc (cdr bucket))))
         )
) ) ) )

;-----------------------------------------------------------------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 (sub1 len)))
      (if (>= i 0)
        (let ((x (+ (* h 256) (char->integer (string-ref str i)))))
          (loop (modulo x n) (sub1 i)))
        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 ---


