;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Hashing and hash table functions for Spice Lisp.
;;; Written by Skef Wholey.
;;;

;;; What a hash-table is:

(defstruct (hash-table (:constructor make-hash-table-structure)
		       (:conc-name hash-table-)
		       (:print-function %print-hash-table))
  "Structure used to implement hash tables."
  (kind 'eq)
  (size 65 :type fixnum)
  (rehash-size 101)				; might be a float
  (rehash-threshold 57 :type fixnum)
  (number-entries 0 :type fixnum)
  (table () :type simple-vector))

;;; A hash-table-table is a vector of association lists.  When an
;;; entry is made in a hash table, a pair of (key . value) is consed onto
;;; the element in the vector arrived at by hashing.

;;; How to print one:

(defun %print-hash-table (structure stream depth)
  depth
  (write-string "#<" stream)
  (write-string (symbol-name (hash-table-kind structure)) stream)
  (write-string " Hash Table>" stream))

;;; Hashing functions for the three kinds of hash tables:

(eval-when (compile)

(defmacro eq-hash (object)
  "Gives us a hashing of an object such that (eq a b) implies
   (= (eq-hash a) (eq-hash b))"
  `(%sp-make-fixnum ,object))

(defmacro eql-hash (object)
  "Gives us a hashing of an object such that (eql a b) implies
   (= (eql-hash a) (eql-hash b))"
  `(if (numberp ,object)
       (abs (truncate ,object))
       (%sp-make-fixnum ,object)))

(defmacro equal-hash (object)
  "Gives us a hashing of an object such that (equal a b) implies
   (= (equal-hash a) (equal-hash b))"
  `(sxhash ,object))

)

;;; Rehashing functions:

(defun almost-primify (num)
  (declare (fixnum num))
  "Almost-Primify returns an almost prime number greater than or equal
   to NUM."
  (if (= (rem num 2) 0)
      (setq num (+ 1 num)))
  (if (= (rem num 3) 0)
      (setq num (+ 2 num)))
  (if (= (rem num 7) 0)
      (setq num (+ 4 num)))
  num)

(eval-when (compile)

(defmacro grow-size (table)
  "Returns a fixnum for the next size of a growing hash-table."
  `(let ((rehash-size (hash-table-rehash-size ,table)))
     (if (floatp rehash-size)
	 (ceiling (* rehash-size (hash-table-size ,table)))
	 (+ rehash-size (hash-table-size ,table)))))

(defmacro grow-rehash-threshold (table new-length)
  "Returns the next rehash threshold for the table."
  table
  `,new-length
;  `(ceiling (* (hash-table-rehash-threshold ,table)
;	       (/ ,new-length (hash-table-size ,table))))
  )

(defmacro hash-set (vector key value length hashing-function)
  "Used for rehashing.  Enters the value for the key into the vector
   by hashing.  Never grows the vector.  Assumes the key is not yet
   entered."
  `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
		     (the fixnum ,length))))
     (declare (fixnum index))
     (setf (aref (the simple-vector ,vector) index)
	   (cons (cons ,key ,value)
		 (aref (the simple-vector ,vector) index)))))

)

(defun rehash (structure hash-vector new-length)
  (declare (simple-vector hash-vector))
  (declare (fixnum new-length))
  "Rehashes a hash table and replaces the TABLE entry in the structure if
   someone hasn't done so already.  New vector is of NEW-LENGTH."
  (do ((new-vector (make-vector new-length))
       (i 0 (1+ i))
       (size (hash-table-size structure))
       (hashing-function (case (hash-table-kind structure)
			   (eq #'(lambda (x) (eq-hash x)))
			   (eql #'(lambda (x) (eql-hash x)))
			   (equal #'(lambda (x) (equal-hash x))))))
      ((= i size)
       (cond ((eq hash-vector (hash-table-table structure))
	      (cond ((> new-length size)
		     (setf (hash-table-table structure) new-vector)
		     (setf (hash-table-rehash-threshold structure)
			   (grow-rehash-threshold structure new-length))
		     (setf (hash-table-size structure) new-length))
		    (t
		     (setf (hash-table-table structure) new-vector)))
	      (if (not (eq (hash-table-kind structure) 'equal))
		  (%sp-set-vector-subtype new-vector
					  (+ 2 (%sp-get-newspace-bit)))))))
    (declare (fixnum i size))
    (do ((bucket (aref hash-vector i) (cdr bucket)))
	((null bucket))
      (hash-set new-vector (caar bucket) (cdar bucket) new-length
		hashing-function))))

;;; Macros for Gethash, %Puthash, and Remhash:

(eval-when (compile)

;;; Hashop dispatches on the kind of hash table we've got, rehashes if
;;; necessary, and binds Vector to the hash vector, Index to the index
;;; into that vector that the Key points to, and Size to the size of the
;;; hash vector.  Since Equal hash tables only need to be maybe rehashed
;;; sometimes, one can tell it if it's one of those times with the
;;; Equal-Needs-To-Rehash-P argument.

(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
  `(let* ((vector (hash-table-table hash-table))
	  (size (length vector)))
     (declare (simple-vector vector))
     (declare (fixnum size))
     (case (hash-table-kind hash-table)
       (equal
	,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
	(let ((index (rem (the fixnum (equal-hash key)) size)))
	  (declare (fixnum index))
	  ,equal-body))
       (eq
	(eq-rehash-if-needed)
	(let ((index (rem (the fixnum (eq-hash key)) size)))
	  (declare (fixnum index))
	  ,eq-body))
       (eql
	(eq-rehash-if-needed)
	(let ((index (rem (the fixnum (eql-hash key)) size)))
	  (declare (fixnum index))
	  ,eql-body)))))

(defmacro eq-rehash-if-needed ()
  `(let ((subtype (%sp-get-vector-subtype vector)))
     (declare (fixnum subtype))
     (cond ((or (= subtype 4)
		(/= subtype (+ 2 (%sp-get-newspace-bit))))
	    (rehash hash-table vector size)
	    (setq vector (hash-table-table hash-table)))
	   ((> (hash-table-number-entries hash-table)
	       (hash-table-rehash-threshold hash-table))
	    (rehash hash-table vector (grow-size hash-table))
	    (setq vector (hash-table-table hash-table))
	    (setq size (length vector))))))

(defmacro equal-rehash-if-needed ()
  `(cond ((> (hash-table-number-entries hash-table)
	     (hash-table-rehash-threshold hash-table))
	  (rehash hash-table vector (grow-size hash-table))
	  (setq vector (hash-table-table hash-table))
	  (setq size (length vector)))))

(defmacro rehash-if-needed ()
  `(let ((subtype (%sp-get-vector-subtype vector))
	 (size (length vector)))
     (declare (fixnum subtype size))
     (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
		 (or (= subtype 4)
		     (/= subtype (+ 2 (%sp-get-newspace-bit)))))
	    (rehash hash-table vector size)
	    (setq vector (hash-table-table hash-table))
	    (setq size (length vector)))
	   ((> (hash-table-number-entries hash-table)
	       (hash-table-rehash-threshold hash-table))
	    (rehash hash-table vector (grow-size hash-table))
	    (setq vector (hash-table-table hash-table))
	    (setq size (length vector))))))

)

;;; Making hash tables:

(defun make-hash-table (&rest options)
  "Creates and returns a hash table.  See manual for details."
  (with-keywords options
      ((:test test 'eql)
       (:size size 65)
       (:rehash-size rehash-size 101)
       (:rehash-threshold rehash-threshold))
    (declare (fixnum size))
    (cond ((eq test #'eq) (setq test 'eq))
	  ((eq test #'eql) (setq test 'eql))
	  ((eq test #'equal) (setq test 'equal)))
    (setq size (if (<= size 37) 37 (almost-primify size)))
    (cond ((null rehash-threshold)
	   (setq rehash-threshold size))
	  ((floatp rehash-threshold)
	   (setq rehash-threshold (ceiling (* rehash-threshold size)))))
    (make-hash-table-structure ':size size
			       ':rehash-size rehash-size
			       ':rehash-threshold rehash-threshold
			       ':table
			       (if (eq test 'equal)
				   (make-vector size)
				   (%sp-set-vector-subtype
				    (make-vector size)
				    (+ 2 (%sp-get-newspace-bit))))
			       ':kind test)))

;;; Manipulating hash tables:

(defun gethash (key hash-table &optional default)
  "Finds the entry in Hash-Table whose key is Key and returns the associated
   value and T as multiple values, or returns Default and Nil if there is no
   such entry."
  (hashop nil
   (do ((bucket (aref vector index) (cdr bucket))) ; EQ case
       ((null bucket) (values default nil))
     (if (eq (caar bucket) key)
	 (return (values (cdar bucket) t))))
   (do ((bucket (aref vector index) (cdr bucket))) ; EQL case
       ((null bucket) (values default nil))
     (if (eql (caar bucket) key)
	 (return (values (cdar bucket) t))))
   (do ((bucket (aref vector index) (cdr bucket))) ; EQUAL case
       ((null bucket) (values default nil))
     (if (equal (caar bucket) key)
	 (return (values (cdar bucket) t))))))

(defun %puthash (key hash-table value)
  "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
   is an entry for KEY, replace it.  Returns VALUE."
  (hashop t
   (do ((bucket (aref vector index) (cdr bucket))) ; EQ case
       ((null bucket)
	(push (cons key value) (aref vector index))
	(incf (hash-table-number-entries hash-table))
	value)
     (when (eq (caar bucket) key)
       (rplacd (car bucket) value)
       (return value)))
   (do ((bucket (aref vector index) (cdr bucket))) ; EQL case
       ((null bucket)
	(push (cons key value) (aref vector index))
	(incf (hash-table-number-entries hash-table))
	value)
     (when (eql (caar bucket) key)
       (rplacd (car bucket) value)
       (return value)))
   (do ((bucket (aref vector index) (cdr bucket))) ; EQUAL case
       ((null bucket)
	(push (cons key value) (aref vector index))
	(incf (hash-table-number-entries hash-table))
	value)
     (when (equal (caar bucket) key)
       (rplacd (car bucket) value)
       (return value)))))

(defun remhash (key hash-table)
  "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
   existed; () otherwise."
  (hashop nil
   (let ((bucket (aref vector index)))		; EQ case
     (cond ((and bucket (eq (caar bucket) key))
	    (pop (aref vector index))
	    (decf (hash-table-number-entries hash-table))
	    t)
	   (t
	    (do ((last bucket bucket)
		 (bucket (cdr bucket) (cdr bucket)))
		((null bucket) ())
	      (when (eq (caar bucket) key)
		(rplacd last (cdr bucket))
		(decf (hash-table-number-entries hash-table))
		(return t))))))
   (let ((bucket (aref vector index)))		; EQL case
     (cond ((and bucket (eql (caar bucket) key))
	    (pop (aref vector index))
	    (decf (hash-table-number-entries hash-table))
	    t)
	   (t
	    (do ((last bucket bucket)
		 (bucket (cdr bucket) (cdr bucket)))
		((null bucket) ())
	      (when (eql (caar bucket) key)
		(rplacd last (cdr bucket))
		(decf (hash-table-number-entries hash-table))
		(return t))))))
   (let ((bucket (aref vector index)))		; EQUAL case
     (cond ((and bucket (equal (caar bucket) key))
	    (pop (aref vector index))
	    (decf (hash-table-number-entries hash-table))
	    t)
	   (t
	    (do ((last bucket bucket)
		 (bucket (cdr bucket) (cdr bucket)))
		((null bucket) ())
	      (when (equal (caar bucket) key)
		(rplacd last (cdr bucket))
		(decf (hash-table-number-entries hash-table))
		(return t))))))))

(defun maphash (function hash-table)
  "For each entry in HASH-TABLE, calls FUNCTION on the key and value of the
   entry; returns T."
  (let ((vector (hash-table-table hash-table)))
    (declare (simple-vector vector))
    (rehash-if-needed)
    (do ((i 0 (1+ i))
	 (size (hash-table-size hash-table)))
	((= i size))
      (declare (fixnum i size))
      (do ((bucket (aref vector i) (cdr bucket)))
	  ((null bucket))
	(funcall function (caar bucket) (cdar bucket))))))

(defun clrhash (hash-table)
  "Removes all entries of HASH-TABLE and returns the hash table itself."
  (let ((vector (hash-table-table hash-table)))
    (declare (simple-vector vector))
    (setf (hash-table-number-entries hash-table) 0)
    (do ((i 0 (1+ i))
	 (size (hash-table-size hash-table)))
	((= i size) hash-table)
      (declare (fixnum i size))
      (setf (aref vector i) nil))))

(defun hash-table-count (hash-table)
  "Returns the number of entries in the given Hash-Table."
  (hash-table-number-entries hash-table))

;;; Primitive Hash Function

(defconstant sxhash-max 13 "Number of significant elements to SXHASH.")

(eval-when (compile)

;;; Something that doesn't seem to be provided by any of the rest of
;;; Spice Lisp:

(defmacro sxhash-rot (x num)
  "Rotates X left by NUM bits."
  `(let ((crux (- 27 ,num)))
     (declare (fixnum crux))
     (dpb (ldb (byte crux 0) ,x)
	  (byte crux ,num)
	  (ldb (byte ,num crux) ,x))))

(defmacro sxhash-simple-string (sequence)
  `(%primitive sxhash-simple-string ,sequence))

(defmacro sxhash-string (sequence)
  `(do ((i 0 (1+ i))
	(length (max (%primitive vector-length ,sequence) sxhash-max))
	(hash 0))
       ((= i length) hash)
     (declare (fixnum i length hash))
     (setq hash (sxhash-rot (logxor hash (char-int (aref ,sequence i))) 7))))

(defmacro sxhash-list (sequence)
  `(do ((sequence ,sequence (cdr sequence))
	(index 0 (1+ index))
	(hash 2))
       ((or (atom sequence) (= index sxhash-max)) hash)
     (declare (fixnum hash))
     (setq hash (sxhash-rot (logxor hash (sxhash (car sequence))) 7))))

)

(defun sxhash (s-expr)
  "Computes a hash code for S-EXPR and returns it as an integer."
  (typecase s-expr
    (simple-string (sxhash-simple-string s-expr))
    (symbol (sxhash-simple-string (symbol-name s-expr)))
    (string (sxhash-string s-expr))
    (character (char-int s-expr))
    (list (sxhash-list s-expr))
    (array (array-rank s-expr))
    (float (multiple-value-bind (significand exponent sign)
				(integer-decode-float s-expr)
	     sign
	     (logxor (ldb (byte 23 0) significand)
		     (ldb (byte 23 0) exponent))))
    (integer (ldb (byte 23 0) s-expr))
    (ratio (+ (sxhash (numerator s-expr)) (sxhash (denominator s-expr))))
    (t (%sp-make-fixnum s-expr))))