(include "church/runtime/church_types.state")
(include "church/runtime/church_syntax.state")


(external-function |state-gc-alloc|)
(external-function |state-gc-alloc-and-zero|)
(external-function state-abort)
(external-function church-cons)

; new hash table

(define church-hashtable-allocate (lambda (size)
				    (church-assert (church-> size 0) "size must be greater than 0")
				    (if (not (= (band size (- size 1)) 0))
					(let ((highest-bit (bsr size))
					      (new-size (bshl 1 (+ highest-bit 1))))
;					(call-c-extern printf "given size %lu, new size %lu
;" size new-size)
					(set! size new-size)					  ))
					; size must be a power of 2
				    (church-assert (church-= (band size (- size 1)) 0) "hash table size must be a power of 2")
				    ; hash table is 8 words, plus 2 * size words
				    (let ((ht-alloc-size (+ (* 8 CHURCH_WORD_SIZE) (* size (* 2 CHURCH_WORD_SIZE))))
					  (ht (state-gc-alloc-and-zero ht-alloc-size)))
				      ; clear memory
				      (call-c-extern memset ht 0 ht-alloc-size)
				      
				      (set-hashtable-size! ht size)
				      (set-hashtable-count! ht 0)


;				      (do ((i 0 (+ i 1)))
;					  (< i (hashtable-size ht))
;					(if (not (= (deref (hashtable-table ht) (* 8 i)) 0))
;					    (begin
;					     (call-c-extern printf "ht %p
;" ht)
;					     (state-abort "dirty hashtable"))))

				      
				      ht)))

;(define church-hashtable-set-functions (lambda (ht hash-fn comp-fn)
;					     (set-hashtable-hash-function! ht hash-fn)
;					     (set-hashtable-comp-function! ht comp-fn)
;					     ht))
;; set hash and compare function 
(define church-hashtable-set-functions (lambda (ht hash-fn1 hash-fn2 comp-fn)
					     (set-hashtable-hash-function1! ht hash-fn1)
					     (set-hashtable-hash-function2! ht hash-fn2)					     
					     (set-hashtable-comp-function! ht comp-fn)
					     ht))

(define church-hashtable-has-key? (lambda (ht key)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (comp-fn (hashtable-comp-function ht))
				       (h ((hashtable-hash-function1 ht) key))
				       (index (* (mod h hash-table-size) 2))
				       (probe-step ((hashtable-hash-function2 ht) key)))
				   (tagbody
				      check
				      (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
					(if (= lookup 0)
					    (return TAG_NIL)
					    )
					(if (= (comp-fn lookup key) 0)
					    (return TAG_TRUE)
					    ))
				      (set! h (+ h probe-step))
				      ; mask out high bit
				      (set! h (band h (band -1 (bnot (bshl 1 31)))))
				      (set! index (* (mod h hash-table-size) 2))				      				      
				      (go check)))))

(define church-hashtable-lookup-key (lambda (ht key default-value)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (hash-fn (hashtable-hash-function1 ht))
				       (comp-fn (hashtable-comp-function ht))
				       (h (hash-fn key))
				       (index (* (mod h hash-table-size) 2))
				       (probe-step ((hashtable-hash-function2 ht) key)))
				   (tagbody
				      check
;				      (call-c-extern printf "find_hash_entry at index %lu
;" base-index)
				      (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
					(if (= lookup 0)
					    (return default-value)
					    )
					(if (= (comp-fn lookup key) 0)
					    (return (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)))
					    ))
				      (set! h (+ h probe-step))
				      ; mask out high bit
				      (set! h (band h (band -1 (bnot (bshl 1 31)))))
				      (set! index (* (mod h hash-table-size) 2))
				      (go check)))
				 (state-abort "failed find hash entry")))

(define church-hashtable-add-or-replace (lambda (ht key value)
;					  (call-c-extern printf "church-hashtable-add-or-replace %p size %lu count %lu
;" ht (hashtable-size ht) (hashtable-count ht))
					  (let ((new-count (church-hashtable-add-or-replace-helper ht key value)))
					    (if (> new-count 0)
						(begin
						 (set-hashtable-count! ht (+ (hashtable-count ht) 1))
;						 (call-c-extern printf "ht %p count %lu size %lu
;" ht (hashtable-count ht) (hashtable-size ht))
					; check if we should grow
						 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)
						     (let ((newsize (* (hashtable-size ht) 2))
							   (new-ht (church-hashtable-allocate newsize)))
					; copy the old functions into the new table
						       (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))
						       (church-hashtable-rehash-from-old-table ht new-ht)
						       (return new-ht))
						     ht))
						ht))))

(define church-hashtable-add-or-replace-helper (lambda (ht key value)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (hash-fn (hashtable-hash-function1 ht))
				       (comp-fn (hashtable-comp-function ht))
				       (h (hash-fn key))
				       (index (* (mod h hash-table-size) 2))
				       (probe-step ((hashtable-hash-function2 ht) key)))
				   (tagbody
				      check
;				      (call-c-extern printf "ht %p h %p index %lu, key %p value %p probe-step %p
;" ht h index key value probe-step)
				      (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
					(if (= lookup 0)
					    ;add a new entry
					    (begin
					     (set-long! hash-table (* index CHURCH_WORD_SIZE) key)
					     (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) value)
					     (return 1))) ; 1 for new entry
					(if (= (comp-fn lookup key) 0)
					; overwrite current entry
					    (begin
;					     (call-c-extern printf "h %p index %lu at index %lu, overwrite %p %p %lu
;" h index index lookup key (comp-fn lookup key))		     
					     (set-long! hash-table (* index CHURCH_WORD_SIZE) key)
					     (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) value)
					     (return 0)))) ; 0 for replacement of old entry
				      (set! h (+ h probe-step))
				      ; mask out high bit
				      (set! h (band h (band -1 (bnot (bshl 1 31)))))
				      (set! index (* (mod h hash-table-size) 2))				      
				      (go check)))
				 (state-abort "failed find hash entry")))

(define church-hashtable-rehash-from-old-table (lambda (ht new-ht)
						 (let ((hash-table (hashtable-table ht))
						       (hash-table-size (hashtable-size ht)))
						   (let ((counter 0)
							 (base-index 0))
						     (tagbody
						      check
							(if (< counter hash-table-size)
							    (let ((key (deref hash-table (* base-index CHURCH_WORD_SIZE)))
								  (value (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE))))
							      (if (not (= key 0))
								  (begin
								   (church-hashtable-add-or-replace-helper new-ht key value)
								   (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))
								  )
							      (set! base-index (+ base-index 2)))
							    (go end))
							(set! counter (+ counter 1))
							(go check)
						      end)))))

(external-function church-reverse!)
(define church-hashtable-keys (lambda (ht)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (counter 0)
				       (base-index 0)
				       (keys TAG_NIL))
				   (tagbody
				    check
				      (if (< counter hash-table-size)
					  (let ((key (deref hash-table (* base-index CHURCH_WORD_SIZE))))
					    (if (not (= key 0))
						(push key keys))
					    (set! base-index (+ base-index 2)))
					  (go end))
				      (set! counter (+ counter 1))
				      (go check)
				    end)
				   (church-reverse! keys))))

; hash functions

(define church_hash_string_function (lambda (str)
			     (let ((h 0))
			       (tagbody
				check
				(if (= (get-byte str 0) 0)
				    (go done)
				    (begin
				     (set! h (+ (* h 31) (get-byte str 0)))
				     (set! str (+ str 1))
				     (go check)))
			       done)
			       (bshr (bshl h 1) 1) ; mask out any sign bit
			       )))

(define church_second_hash_string_function (lambda (str)
					     (let ((hash 0))
					       (tagbody
						check
						  (if (= (get-byte str 0) 0)
						      (go done)
						      (begin
						       (set! hash (+ hash (get-byte str 0)))
						       (set! hash (+ hash (bshl hash 10)))
						       (set! hash (bxor hash (bshr hash 6)))						       
						       (set! str (+ str 1))
						       ))
						  done)
					       (set! hash (+ hash (bshl hash 3)))
					       (set! hash (bxor hash (bshr hash 11)))
					       (set! hash (+ hash (bshl hash 15)))
					; our result must always be odd to be relatively prime to the size of table (multiple of 2)
					       (bor
						(bshr (bshl hash 1) 1) ; mask out any sign bit						
						1))))

(define church_compare_string_function (lambda (a b)
;					 (call-c-extern printf "comparing strings %p %p '%s' '%s'
;" a b a b)
					 (call-c-extern strcmp a b)))

(define church_default_hash_function (lambda (key1)
				       (let ((p 16777619)
					     (h 2166136261))
					 ; unroll 4 times for each byte in the key
					 (set! h (* p (bxor h (band key1 #xff))))
					 (set! key1 (bshr key1 8))
					 (set! h (* p (bxor h (band key1 #xff))))
					 (set! key1 (bshr key1 8))
					 (set! h (* p (bxor h (band key1 #xff))))
					 (set! key1 (bshr key1 8))
					 (set! h (* p (bxor h (band key1 #xff))))
					 
					 (set! h (+ h (bshl h 13)))
					 (set! h (bxor h (bshr h 7)))
					 (set! h (+ h (bshl h 3)))
					 (set! h (bxor h (bshr h 17)))					 
					 (set! h (+ h (bshl h 5)))
					 (band h (band -1 (bnot (bshl 1 31))))
)))


(define church_default_second_hash_function (lambda (key1)
					      (let ((hash 0))
						(do ((i 0 (+ i 1)))
						    (< i 4)
						  (set! hash (+ hash (band key1 #xff)))
						  (set! hash (+ hash (bshl hash 10)))
						  (set! hash (bxor hash (bshr hash 6)))
						  (set! key1 (bshr key1 8))
						  )
					      (set! hash (+ hash (bshl hash 3)))
					      (set! hash (bxor hash (bshr hash 11)))
					      (set! hash (+ hash (bshl hash 15)))
					; our result must always be odd to be relatively prime to the size of table (multiple of 2)
					      (bor
					       (band hash (band -1 (bnot (bshl 1 31))))
					       1))))

(define church_default_compare_function (lambda (a b)
					  (- a b)))

(external-function church_profiled_apply1)
(external-function church_profiled_apply2)
(external-function state-init-constant)
(external-function state-alloc-constant-vector)

(define church_equal_hash_function (lambda (obj)
				     (apply 'hash obj)))
(define church_equal_compare_function (lambda (a b)
					(let ((result (apply 'equal? a b)))
					  (if (= result TAG_TRUE)
					      0
					      (- b a)))))


; two key hashtable

; new hash table

(define church-two-key-hashtable-allocate (lambda (size)
					    (church-assert (church-> size 0) "size must be greater than 0")
					    (if (not (= (band size (- size 1)) 0))
						(let ((highest-bit (bsr size))
						      (new-size (bshl 1 (+ highest-bit 1))))
;						  (call-c-extern printf "church-two-key-hashtable-allocate given size %lu, new size %lu
;" size new-size)
						  (set! size new-size)))
					; size must be a power of 2
					    (church-assert (church-= (band size (- size 1)) 0) "hash table size must be a power of 2")
					; hash table is 8 words, plus 4 * size words
					    (let ((ht-alloc-size (+ (* 8 CHURCH_WORD_SIZE) (* size (* 4 CHURCH_WORD_SIZE))))
						  (ht (state-gc-alloc-and-zero ht-alloc-size)))
					      (if (= ht 0)
						  (state-abort "hash table alloc failed"))
					; clear memory
					      (call-c-extern memset ht 0 ht-alloc-size)					      
					      (set-hashtable-size! ht size)
					      (set-hashtable-count! ht 0)
					      ; 0 probes
;					      (set-long! ht (* 7 CHURCH_WORD_SIZE) 0)
					      ht)))

;(define church-two-key-hashtable-print-stats (lambda (ht)
;					       (call-c-extern printf "two hash-table count %lu probes %lu, avg probes %lu
;" (hashtable-count ht) (deref ht (* 7 CHURCH_WORD_SIZE)) (/ (deref ht (* 7 CHURCH_WORD_SIZE))  (hashtable-count ht) ))))


(define church-two-key-hashtable-has-keys? (lambda (ht key1 key2)
					     (state-abort "has keys")
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (hash-fn (hashtable-hash-function ht))
				       (comp-fn (hashtable-comp-function ht))
				       (h (bor (hash-fn key1) (hash-fn key2)))
				       (index (mod h hash-table-size))
				       ; align to 4 word boundary
				       (base-index (band (* index 4) -4))
				       (orig-index base-index))
				   (tagbody
				      check
				      (let ((lookup1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))
					    (lookup2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE))))
					(if (and (= lookup1 0)
						 (= lookup2 0))
					    (return TAG_NIL))
					(if (and (= (comp-fn lookup1 key1) 0)
						 (= (comp-fn lookup2 key2) 0))
					    (return TAG_TRUE)))
				      (set! base-index (+ base-index 4))
					; check if we have wrappend around the top of the table				      
				      (if (= base-index (* hash-table-size 4))
					  (set! base-index 0))
				      (go check)))))

; return a pointer to the result
; 0 if not found
(define church-two-key-hashtable-lookup-keys (lambda (ht key1 key2)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (h (church-two-key-hash-function key1 key2))
				       (index (* (mod h hash-table-size) 4))				       
				       (probe-step (church-two-key-second-hash-function key1 key2)))
				   (tagbody
				      check
				      ; note that the first key cannot be a fixnum
				      (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
					(if (= l1 0)
					    (return 0))
					(if (= l1 key1)
					    (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
						 (return (+ hash-table (* (+ index 2) CHURCH_WORD_SIZE))))))
				      (set! h (+ h probe-step))
				      ; mask out high bit
				      (set! h (band h (band -1 (bnot (bshl 1 31)))))
				      (set! index (* (mod h hash-table-size) 4))
				      (go check)))
				 (state-abort "failed find hash entry")))


(define church-two-key-hashtable-add-or-replace (lambda (ht key1 key2 value1 value2)
					  (let ((new-count (church-two-key-hashtable-add-or-replace-helper ht key1 key2 value1 value2)))
					    (if (> new-count 0)
						(begin
						 (set-hashtable-count! ht (+ (hashtable-count ht) 1))
;						 (call-c-extern printf "after add two-key ht %p count %lu size %lu
;" ht (hashtable-count ht) (hashtable-size ht))
					; check if we should grow
						 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)
						     (let ((newsize (* (hashtable-size ht) 2))
							   (new-ht (church-two-key-hashtable-allocate newsize)))
;(call-c-extern printf "growing two key ht %p count %lu size %lu
;" ht (hashtable-count ht) newsize)
					; copy the old functions into the new table
						       (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))
						       (church-two-key-hashtable-rehash-from-old-table ht new-ht)
						       (return new-ht))
						     ht))
						ht))))

(define church-two-key-hashtable-add-or-replace-helper (lambda (ht key1 key2 value1 value2)
				 (let ((hash-table (hashtable-table ht))
				       (hash-table-size (hashtable-size ht))
				       (h (church-two-key-hash-function key1 key2))				       				       
				       (index (* (mod h hash-table-size) 4))
				       (probe-step (church-two-key-second-hash-function key1 key2)))
;				      (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p) 
;" key1 key2 h index index index)				   
				   (tagbody
				      check
				      
				      (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
					(if (= l1 0)
					    (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) 0)
						(begin
						 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
						 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
						 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
						 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)					     					     					     
						 (return 1) ; new entry
						 )))
					(if (= l1 key1)
					    (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
						(begin
						 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
						 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
						 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
						 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)					     					     					     
						 (return 0) ; existing entry
						 ))))
;				      (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p) PROBING
;" key1 key2 h index index index)
				      ; count the number of probes
;				      (set-long! ht (* 7 CHURCH_WORD_SIZE) (+ 1 (deref ht (* 7 CHURCH_WORD_SIZE))))
				      (set! h (+ h probe-step))
				      ; mask out high bit
				      (set! h (band h (band -1 (bnot (bshl 1 31)))))
				      (set! index (mod h hash-table-size))
				      (go check)))
				 (state-abort "failed find hash entry")))

(define church-two-key-hashtable-rehash-from-old-table (lambda (ht new-ht)
						 (let ((hash-table (hashtable-table ht))
						       (hash-table-size (hashtable-size ht)))
						   (let ((counter 0)
							 (base-index 0))
						     (tagbody
						      check
							(if (< counter hash-table-size)
							    (let ((key1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))
								  (key2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE)))
								  (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) ))
								  (value2 (deref hash-table (* (+ base-index 3) CHURCH_WORD_SIZE) ))								  								  (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) )))
							      (if (not (and (= key1 0)
									    (= key2 0)))
								  (begin
								   (church-two-key-hashtable-add-or-replace-helper new-ht key1 key2 value1 value2)
								   (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))
								  )
							      (set! base-index (+ base-index 4)))
							    (go end))
							(set! counter (+ counter 1))
							(go check)
						      end)))))

; Modified FNV from Pluto Scarab, http://home.comcast.net/~bretm/hash/6.html

(define church-two-key-hash-function (lambda (key1 key2)
				       (let ((p 16777619)
					     (h 2166136261))
					 (do ((i 0 (+ i 1)))
					     (< i 4)
					   (set! h (* p (bxor h (band key1 #xff))))
;					   (call-c-extern printf "hash1 %p key1 %p
;" h key1)
					   (set! key1 (bshr key1 8)))
					 (do ((i 0 (+ i 1)))
					     (< i 4)
					   (set! h (* p (bxor h (band key2 #xff))))
;					   (call-c-extern printf "hash1 %p key2 %p
;" h key2)					   
					   (set! key2 (bshr key2 8)))
					 (set! h (+ h (bshl h 13)))
					 (set! h (bxor h (bshr h 7)))
					 (set! h (+ h (bshl h 3)))
					 (set! h (bxor h (bshr h 17)))					 
					 (set! h (+ h (bshl h 5)))
					 (band h (band -1 (bnot (bshl 1 31))))					 )))


; Jenkins hash function from wikipedia / dr. dobbs

(define church-two-key-second-hash-function (lambda (key1 key2)
					      (let ((hash 0))
						(do ((i 0 (+ i 1)))
						    (< i 4)
						  (set! hash (+ hash (band key1 #xff)))
						  (set! hash (+ hash (bshl hash 10)))
						  (set! hash (bxor hash (bshr hash 6)))
						  (set! key1 (bshr key1 8))
						  )
					      (do ((i 0 (+ i 1)))
						  (< i 4)
						(set! hash (+ hash (band key2 #xff)))
						(set! hash (+ hash (bshl hash 10)))
						(set! hash (bxor hash (bshr hash 6)))
						(set! key2 (bshr key1 8))
						)
					      (set! hash (+ hash (bshl hash 3)))
					      (set! hash (bxor hash (bshr hash 11)))
					      (set! hash (+ hash (bshl hash 15)))
					; our result must always be odd to be relatively prime to the size of table (multiple of 2)
					      (bor
					       (band hash (band -1 (bnot (bshl 1 31))))
					       1))))