;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/hash-object.sc,v 1.4 90/04/01 13:50:25 johani Exp $

;;; hash.sc -- implements a general hash-object. The caller provides functions
;;;            for obtaining the key from the objects to be used, and for
;;;            hashing these keys. The hash-table is implemented as a vector,
;;;            in which each element is an association list consisting of
;;;            pairs of the form
;;;            (<key> . <object>).
;;;            A hash-object is created by
;;;               (make-hash-vector <hash function>
;;;                                 <key function>
;;;                                 <initial size>),
;;;            where <hash function> is a function of one parameter (a key),
;;;            returning an integer between 0 and "maxint", <key function>
;;;            is a function of one argument (an object to be contained in
;;;            the table) returning a (preferrably unique) key suitable for
;;;            <key function> and <initial size> is the size to be used for
;;;            the hash vector. (Note: this should, according to theory, be
;;;            a prime number. This is always seen to when the table is
;;;            rehashed, but not for the initial size. Thus, <initial size>
;;;            should be prime.)
;;;            Supported operations are:
;;;               (hvec 'insert! obj ...)    => 'done (always)
;;;               (hvec 'remove! obj ...)    => 'done (always)
;;;               (hvec 'lookup key)         => obj : (eqv? (keyfun obj) key)
;;;                                             or #f if none found.
;;;               (hvec 'rehash!)            => 'done (always)
;;;               (hvec 'contents)           => A list containing all elements
;;;                                             of the hash-vector.
;;;               + the "standard" messages 'object-class (=> 'hash-vector),
;;;               'object-system (=> 'light-weight) and 'supported-messages.
;;;            Rehashing is automatically done when the ratio
;;;            <vector length>/<number of elements in vector> is less than
;;;            0.25. When rehashing, the size of the hash-table is increased
;;;            to the smallest prime larger than 5 * <old size>.

(module hash)

(define (make-hash-vector hashfun keyfun initial-size)
  (let ((hash-vector (make-vector initial-size '()))
	(no-of-elems 0))
    (define (usage)
      (if (zero? no-of-elems)
	  4711
	  (/ (vector-length hash-vector) no-of-elems) ))
    (define (make-prime n)		; Returns smallest prime larger than n
      (if (even? n)
	  (make-prime (+ n 1))
	  (let loop ((i 3))
	    (if (zero? (modulo n i))
		(make-prime (+ n 2))
		(if (> (* i i) n)
		    n
		    (loop (+ i 2)) )))))
    (define (insert! obj no vec)
      (let ((pos (inexact->exact (modulo no (vector-length vec)))))
	(vector-set! vec
		     pos
		     (cons (cons (keyfun obj) obj)
			   (vector-ref vec pos) ))))
    (define (rehash!)
      (let ((new-vec (make-vector
		      (make-prime
		       (* (vector-length hash-vector)
			  5))
		      '())))
	(let loop ((i 0))
	  (if (= i (vector-length hash-vector))
	      (set! hash-vector new-vec)
	      (begin
		(for-each (lambda (o)
			    (insert! (cdr o)
				     (hashfun (car o))
				     new-vec))
			  (vector-ref hash-vector i) )
		(loop (+ i 1)) ))))
      'done)
    (define (lookup key)
      (assv key
	    (vector-ref hash-vector
			(inexact->exact
			 (modulo (hashfun key)
				 (vector-length hash-vector) )))))
    (define (contents)
	(let loop ((ls (remove '() (vector->list hash-vector))) (result '()))
	  (if (null? ls)
	      result
	      (loop (cdr ls) (append (map cdr (car ls)) result)) )))
    (define (me msg . args)
      ;;(format #t "Hash-object recieved a ~a-message. Args: ~a~%" msg args)
      ;;(flush-buffer)
      (cond ((eq? msg 'object-class) 'hash-vector)
	    ((eq? msg 'object-system) 'light-weight)
	    ((eq? msg 'supported-messages)
	     '(insert! rehash! lookup remove! contents) )
	    ((eq? msg 'insert!)
	     (if (< (usage) .25) (rehash!)) ; .25 somewhat arbitrary...
	     (let ((n-list (map (lambda (obj)
				  (hashfun (keyfun obj)) )
				args)))
	       (let loop ((l1 args) (l2 n-list))
		 (if (not (null? l1))
		     (begin
		       (insert! (car l1) (car l2) hash-vector)
		       (set! no-of-elems (+ no-of-elems 1))
		       (loop (cdr l1) (cdr l2)) ))))
	     'done)
	    ((eq? msg 'insert-with-key!) ; Needed by resource: scix-announce-id
	     (if (< (usage) .25) (rehash!)) ; .25 somewhat arbitrary...
	     (insert! (car args) (hashfun (cadr args)) hash-vector)
	     (set! no-of-elems (+ no-of-elems 1))
	     'done)
	    ((eq? msg 'hash-vector) hash-vector) ; Debug
	    ((eq? msg 'rehash!) (rehash!))
	    ((eq? msg 'lookup)
	     (let ((the-pair (lookup (car args))))
	       (if the-pair
		   (cdr the-pair)
		   #f)))
	    ((eq? msg 'contents) (contents))
	    ((eq? msg 'remove!)
	     (for-each (lambda (o)
			 (let* ((no (hashfun (keyfun o)))
				(the-obj (lookup (keyfun o)))
				(modno (modulo no
					       (vector-length hash-vector)) ))
			   (if the-obj
			       (begin
				 (vector-set! hash-vector
					      modno
					      (remq! the-obj
						     (vector-ref hash-vector
								 modno)))
				 (set! no-of-elems (- no-of-elems 1)) ))))
		       args)
	     'done)
	    (else (error 'hash-vector "No such message: ~a" msg)) ))
    me))