;; -*-theme-d-*-

;; Copyright (C) 2019  Tommi Höynälänmaa

(define-body (standard-library hash-table2)

  (import (standard-library list-utilities))
  
  (define gl-i-default-hash-table-size 100)
  
  (define-param-proc make-hash-table (%key %value)
		     (((proc-hash (:hash-proc %key))
		       (proc-assoc (:assoc-proc %key %value))
		       (proc-delete (:alist-delete-proc %key %value)))
		      (:hash-table %key %value)
		      pure)
    (make (:hash-table %key %value)
	  (make-mutable-vector (:alist %key %value)
			       gl-i-default-hash-table-size
			       null)
	  proc-hash proc-assoc proc-delete))

  (define-param-proc make-hash-table-with-size (%key %value)
		     (((proc-hash (:hash-proc %key))
		       (proc-assoc (:assoc-proc %key %value))
		       (proc-delete (:alist-delete-proc %key %value))
		       (i-size <integer>))
		      (:hash-table %key %value)
		      pure)
    (make (:hash-table %key %value)
	  (make-mutable-vector (:alist %key %value)
			       i-size
			       null)
	  proc-hash proc-assoc proc-delete))

  (define-param-proc make-object-hash-table (%value)
		     (() (:object-hash-table %value) pure)
    ((param-proc-instance make-hash-table <object> %value)
     object-hash
     (param-proc-instance assoc-objects1 <object> %value)
     (param-proc-instance object-alist-delete <object> %value)))   

  (define-param-proc make-object-hash-table-with-size (%value)
		     (((i-size <integer>)) (:object-hash-table %value) pure)
    ((param-proc-instance make-hash-table-with-size <object> %value)
     object-hash
     (param-proc-instance assoc-objects1 <object> %value)
     (param-proc-instance object-alist-delete <object> %value)
     i-size))

  (define-param-proc make-string-hash-table (%value)
		     (() (:string-hash-table %value) pure)
    ((param-proc-instance make-hash-table <string> %value)
     string-hash
     (param-proc-instance assoc-values1 <string> %value)
     (param-proc-instance value-alist-delete <string> %value)))     

  (define-param-proc make-string-hash-table-with-size (%value)
		     (((i-size <integer>)) (:string-hash-table %value) pure)
    ((param-proc-instance make-hash-table-with-size <string> %value)
     string-hash
     (param-proc-instance assoc-values1 <string> %value)
     (param-proc-instance value-alist-delete <string> %value)
     i-size))

  (define-param-proc make-symbol-hash-table (%value)
		     (() (:symbol-hash-table %value) pure)
    ((param-proc-instance make-hash-table <symbol> %value)
     hashq
     (param-proc-instance assoc-values1 <symbol> %value)
     (param-proc-instance value-alist-delete <symbol> %value)))     

  (define-param-proc make-symbol-hash-table-with-size (%value)
		     (((i-size <integer>)) (:symbol-hash-table %value) pure)
    ((param-proc-instance make-hash-table-with-size <symbol> %value)
     hashq
     (param-proc-instance assoc-values1 <symbol> %value)
     (param-proc-instance value-alist-delete <symbol> %value)
     i-size))

  (define-param-proc hash-ref (%key %value %default)
		     (((ht (:hash-table %key %value)) (o-key %key)
		       (o-default %default))
		      (:union %value %default) pure)
    (let* ((proc-hash (field-ref ht 'proc-hash))
	   (proc-assoc (field-ref ht 'proc-assoc))
	   (v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents))
	   (i-hash (proc-hash o-key i-size))
	   (al (mutable-vector-ref v-al-contents i-hash))
	   (p (proc-assoc o-key al)))
      (match-type-strong p
	((b <boolean>)
	 (assert (equal? b #f))
	 o-default)
	((p1 (:pair %key %value))
	 (cdr p1)))))
  
  (define-param-proc hash-exists? (%key %value)
		     (((ht (:hash-table %key %value)) (o-key %key))
		      <boolean> pure)
    (let* ((proc-hash (field-ref ht 'proc-hash))
	   (proc-assoc (field-ref ht 'proc-assoc))
	   (v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents))
	   (i-hash (proc-hash o-key i-size))
	   (al (mutable-vector-ref v-al-contents i-hash))
	   (p (proc-assoc o-key al)))
      (not (equal? p #f))))

  ;; Precondition:
  ;;   Key o-key shall not be present in v-al-contents.
  ;;   Number i-hash shall be the hash value computed for o-key.
  (define-param-proc hash-set-new1! (%key %value)
		     (((v-al-contents
			(:mutable-vector (:alist %key %value)))
		       (o-key %key)
		       (o-value %value)
		       (i-hash <integer>))
		      <none> nonpure)
    (mutable-vector-set! v-al-contents i-hash
			 (cons (cons o-key o-value)
			       (mutable-vector-ref v-al-contents i-hash))))
	   
  ;; Precondition:
  ;;   Number i-hash shall be the hash value computed for o-key.
  (define-param-proc hash-remove1! (%key %value)
		     (((v-al-contents
			(:mutable-vector (:alist %key %value)))
		       (proc-delete (:alist-delete-proc %key %value))
		       (o-key %key)
		       (i-hash <integer>))
		      <none> nonpure)
    (mutable-vector-set! v-al-contents i-hash
			 (proc-delete
			  o-key
			  (mutable-vector-ref v-al-contents i-hash))))

  (define-param-proc hash-set! (%key %value)
		     (((ht (:hash-table %key %value))
		       (o-key %key)
		       (o-value %value))
		      <none> nonpure)
    (let* ((proc-hash (field-ref ht 'proc-hash))
	   (proc-delete (field-ref ht 'proc-delete))
	   (v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents))
	   (i-hash (proc-hash o-key i-size)))
      (hash-remove1! v-al-contents proc-delete o-key i-hash)
      (hash-set-new1! v-al-contents o-key o-value i-hash)))
  
  (define-param-proc hash-remove! (%key %value)
		     (((ht (:hash-table %key %value)) (o-key %key))
		      <none> nonpure)
    (let* ((proc-hash (field-ref ht 'proc-hash))
	   (proc-delete (field-ref ht 'proc-delete))
	   (v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents))
	   (i-hash (proc-hash o-key i-size)))
      (mutable-vector-set! v-al-contents i-hash
			   (proc-delete
			    o-key
			    (mutable-vector-ref v-al-contents i-hash)))))
  
  (define-param-proc hash-count (%key %value)
		     (((pred (:binary-predicate %key %value))
		       (ht (:hash-table %key %value)))
		      <integer> pure)
    (let* ((v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents)))
      (let-volatile ((i-count <integer> 0))
	(do ((i-al <integer> 0 (+ i-al 1))) ((>= i-al i-size) i-count)
	  (for-each1
	   (lambda (((p (:pair %key %value))) <none> pure)
	     (if (pred (car p) (cdr p))
		 (set! i-count (+ i-count 1))))
	   (mutable-vector-ref v-al-contents i-al))))))
  
  (define-param-proc hash-count-elements (%key %value)
		     (((ht (:hash-table %key %value)))
		      <integer> pure)
    (hash-count (lambda (((x-key %key) (x-value %value)) <boolean> pure) #t)
		ht))

  (define hashq
    (unchecked-prim-proc hashq (<object> <integer>) <integer> pure))
    
  (define hashv
    (unchecked-prim-proc hashv (<object> <integer>) <integer> pure))

  (define hash-contents
    (unchecked-prim-proc hash-contents (<object> <integer>) <integer> pure))

  (define object-hash
    (unchecked-prim-proc hashv (<object> <integer>) <integer> pure))

  (define string-hash
    (unchecked-prim-proc theme-string-hash (<string> <integer>) <integer> pure))

  (define-param-proc hash-for-each (%key %value)
		     (((proc (:procedure (%key %value) <none> nonpure))
		       (ht (:hash-table %key %value)))
		      <none>
		      nonpure)
    (let* ((v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents)))
      (let-mutable ((i-count <integer> 0))
	(do ((i-al <integer> 0 (+ i-al 1))) ((>= i-al i-size) i-count)
	  (for-each1
	   (lambda (((p (:pair %key %value))) <none> nonpure)
	     (proc (car p) (cdr p)))
	   (mutable-vector-ref v-al-contents i-al))))))


  (define-param-proc hash-search-first (%key %value %default)
		     (((pred (:binary-predicate %key %value))
		       (ht (:hash-table %key %value))
		       (x-default %default))
		      (:union %value %default)
		      pure)
    (let* ((v-al-contents (field-ref ht 'v-al-contents))
	   (i-size (mutable-vector-length v-al-contents)))
      (let-mutable ((x-result (:union %value %default) x-default)
		    (found? <boolean> #f))
	(do ((i-al <integer> 0 (+ i-al 1)))
	    ((or found? (>= i-al i-size)) x-result)
	  (let ((al (mutable-vector-ref v-al-contents i-al)))
	    (let ((p-search
		   (find (lambda (((p (:pair %key %value))) <boolean> pure)
			   (pred (car p) (cdr p)))
			 al
			 #f)))
	      (match-type-strong p-search
		((b <boolean>)
		 (assert (equal? b #f))
		 null)
		((p1 (:pair %key %value))
		 (set! x-result (cdr p1))
		 (set! found? #t)))))))))


  (define-param-proc mutable-vector-fill! (%type)
		     (((v (:mutable-vector %type))
		       (x-value %type))
		      <none> nonpure)
    (let ((i-size (mutable-vector-length v)))
      (do ((i <integer> 0 (+ i 1))) ((>= i i-size))
	(mutable-vector-set! v i x-value))))
  
  (define-param-proc hash-clear! (%key %value)
		     (((ht (:hash-table %key %value))) <none> nonpure)
    (mutable-vector-fill! (field-ref ht 'v-al-contents) null))

  (define-param-proc assoc1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc key lst #f))

  (define-param-proc assoc-values1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-values key lst #f))
  
  (define-param-proc assoc-objects1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-objects key lst #f))

  (define-param-proc assoc-contents1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-contents key lst #f)))
