;;;; lookup-table-body.scm
;;;; Kon Lovett, Sep '09

;;;

(define-syntax safety
  (syntax-rules ()
    ((_ body ...) (cond-expand (unsafe) (else body ... ))) ) )

;;;

;;; Variant Dictionary

(define-record-type/primitive dict
	(make-dictbase data)
	dict?
	(data dict-data-ref dict-data-set!)
	(test dict-test-ref dict-test-set!)
	(to-alist dict->alist-ref dict->alist-set!)
	(ref dict-ref-ref dict-ref-set!)
	(set dict-set-ref dict-set-set!)
	(delete dict-delete-ref dict-delete-set!)
	(for-each dict-for-each-ref dict-for-each-set!)
	(merge dict-merge-ref dict-merge-set!)
	(search dict-search-ref dict-search-set!)
	(count dict-count-ref dict-count-set!)
	(keys dict-keys-ref dict-keys-set!)
	(values dict-values-ref dict-values-set!)
	(exists dict-exists-ref dict-exists-set!) )

(define (set-dict-procs! dict tst to ref set del for mrg sch cnt keys vals exsts)
	(dict-test-set! dict tst)
	(dict->alist-set! dict to)
	(dict-ref-set! dict ref)
	(dict-set-set! dict set)
	(dict-delete-set! dict del)
	(dict-for-each-set! dict for)
	(dict-merge-set! dict mrg)
	(dict-search-set! dict sch)
	(dict-count-set! dict cnt)
	(dict-keys-set! dict keys)
	(dict-values-set! dict vals)
	(dict-exists-set! dict exsts)
	dict )

; Representation independent primitive calls

(define (dictbase-test dict) ((dict-test-ref dict) (dict-data-ref dict)))
(define (dictbase->alist dict) ((dict->alist-ref dict) (dict-data-ref dict)))
(define (dictbase-ref dict key def) ((dict-ref-ref dict) (dict-data-ref dict) key def))
(define (dictbase-set! dict key val) ((dict-set-ref dict) (dict-data-ref dict) key val))
(define (dictbase-delete! dict key) ((dict-delete-ref dict) (dict-data-ref dict) key))
(define (dictbase-for-each dict proc) ((dict-for-each-ref dict) (dict-data-ref dict) proc))
(define (dictbase-merge! dict1 dict2) ((dict-merge-ref dict1) (dict-data-ref dict1) (dict-data-ref dict2)))
(define (dictbase-search dict proc def) ((dict-search-ref dict) (dict-data-ref dict) proc def))
(define (dictbase-count dict) ((dict-count-ref dict) (dict-data-ref dict)))
(define (dictbase-keys dict) ((dict-keys-ref dict) (dict-data-ref dict)))
(define (dictbase-values dict) ((dict-values-ref dict) (dict-data-ref dict)))
(define (dictbase-exists? dict key) ((dict-exists-ref dict) (dict-data-ref dict) key))

;; Association List

(define (make-alist-data test al) (%cons test al))
(define (alist-dict-test data) (%car data))
(define (alist-dict-alist data) (%cdr data))
(define (alist-dict-alist-set! data al) (%set-cdr! data al))

(define (set-alist-dict-procs! dict)
	(set-dict-procs! dict
		alist-dict-test-ref
		alist-dict->alist
		alist-dict-ref
		alist-dict-set!
		alist-dict-delete!
		alist-dict-for-each
		alist-dict-merge!
		alist-dict-search
		alist-dict-count
		alist-dict-keys
		alist-dict-values
		alist-dict-exists?) )

;; Hash Table

(define (make-htable-data test ht) (%cons test ht))
(define (htable-dict-test data) (%car data))
(define (htable-dict-htable data) (%cdr data))
(define (htable-dict-htable-set! data ht) (%set-cdr!/mutate data ht))

(define (set-htable-dict-procs! dict)
	(set-dict-procs! dict
		htable-dict-test-ref
		htable-dict->alist
		htable-dict-ref
		htable-dict-set!
		htable-dict-delete!
		htable-dict-for-each
		htable-dict-merge!
		htable-dict-search
		htable-dict-count
		htable-dict-keys
		htable-dict-values
		htable-dict-exists?) )

;;;

;;; Alist Dictionary

(define (alist-dict-test-ref data) (alist-dict-test data))

(define (alist-dict->alist data)
  (cond-expand (unsafe (alist-dict-alist data)) (else (list-copy (alist-dict-alist data)))) )

(define (alist-dict-ref data key def)
	(%alist-ref key (alist-dict-alist data) (alist-dict-test data) def) )

(define (alist-dict-set! data key obj)
	(alist-dict-alist-set!
	  data
    (%alist-update! key obj (alist-dict-alist data) (alist-dict-test data))) )

(define (alist-dict-delete! data key)
	(alist-dict-alist-set!
	  data
    (%alist-delete! key (alist-dict-alist data) (alist-dict-test data))) )

(define (alist-dict-for-each data proc)
	(%list-for-each/1
	  (lambda (cell) (proc (%car cell) (%cdr cell)))
    (alist-dict-alist data)) )

(define (alist-dict-merge! data1 data2)
	(let ((test (alist-dict-test data1))
	      (al (alist-dict-alist data1)))
		(%list-for-each/1
		  (lambda (cell) (set! al (%alist-update! (%car cell) (%cdr cell) al test)))
      (alist-dict-alist data2))
		(alist-dict-alist-set! data1 al) ) )

(define (alist-dict-search data proc def) (%alist-find proc (alist-dict-alist data) def))

(define (alist-dict-count data) (%list-length (alist-dict-alist data)))

(define (alist-dict-keys data) (%list-map/1 (lambda (x) (%car x)) (alist-dict-alist data)))

(define (alist-dict-values data) (%list-map/1 (lambda (x) (%cdr x)) (alist-dict-alist data)))

(define (alist-dict-exists? data key)
  (not (%undefined-value? (alist-dict-ref data key (%undefined-value)))) )

(define (make-alist-dict test al)
  (set-alist-dict-procs! (make-dictbase (make-alist-data test al))) )

(define (alist-dict? dict) (%eq? alist-dict-test-ref (dictbase-test dict)))

(define (become-alist-dict! dict)
	(dict-data-set! dict (make-alist-data (dictbase-test dict) (dictbase->alist dict)))
	(set-alist-dict-procs! dict) )

;;; Hash-table Dictionary

(define (htable-dict-test-ref data) (htable-dict-test data))

(define (htable-dict->alist data) (hash-table->alist (htable-dict-htable data)))

(define (htable-dict-ref data key def)
	(hash-table-ref/default (htable-dict-htable data) key def) )

(define (htable-dict-set! data key obj)
	(hash-table-set! (htable-dict-htable data) key obj) )

(define (htable-dict-delete! data key)
	(hash-table-delete! (htable-dict-htable data) key) )

(define (htable-dict-for-each data proc)
	(hash-table-for-each (htable-dict-htable data) proc) )

(define (htable-dict-merge! data1 data2)
	(htable-dict-htable-set!
 	  data1
	  (hash-table-merge! (htable-dict-htable data1) (htable-dict-htable data2))) )

(define (htable-dict-search data proc def)
	(let ((ht (htable-dict-htable data))
				(ret #f))
		(let ((res (let/cc return
                 (hash-table-walk ht
                   (lambda (key val) (when (proc key val) (set! ret #t) (return val)))))))
			(if ret res def) ) ) )

(define (htable-dict-count data) (hash-table-size (htable-dict-htable data)))

(define (htable-dict-keys data) (hash-table-keys (htable-dict-htable data)))

(define (htable-dict-values data) (hash-table-values (htable-dict-htable data)))

(define (htable-dict-exists? data key) (hash-table-exists? (htable-dict-htable data) key))

(define (make-htable-dict test ht)
  (set-htable-dict-procs! (make-dictbase (make-htable-data test ht))) )

(define (htable-dict? dict) (%eq? htable-dict-test-ref (dictbase-test dict)))

(define (become-htable-dict! dict)
	(let ((test (dictbase-test dict)))
		(dict-data-set! dict (make-htable-data test (alist->hash-table (dictbase->alist dict) test))))
	(set-htable-dict-procs! dict) )

;; Argument Checks

(define-check-type dict)

(define (check-value loc obj #!optional nam)
  (when (%undefined-value? obj)
    (error-argument-type loc obj "non-undefined value" nam)) )

(define (check-alist loc obj #!optional nam)
  (check-list loc obj nam)
  (let loop ((al obj) (tal '()))
    (cond ((%null? al) )
          ((not (%pair? (%car al)))
            (error-argument-type loc obj "association list" nam) )
          ((%memq (%cdr al) tal)
            (error-argument-type loc obj "proper list" nam) )
          (else
            (loop (%cdr al) (%cons (%cdr al) tal)) ) ) ) )

;; Errors

(define-error-type dict)

;; Print worker

(define (*dict-print dict)
  (define (print-node-table dict spcr)
    (dictbase-for-each dict
      (lambda (key val)
        (%list-for-each/1 display spcr)
        (cond ((dict? val)
                (write key) (display " :") (newline)
                (print-node-table val (%cons "  " spcr)) )
              (else
                (write key) (display " : ") (pretty-print val)) ) ) ) )
    (print-node-table dict '()) )

;; Update workers

(define (*dict-update! dict key valu-func updt-func curr loc)
  (let ((val (updt-func
               (if (not (%undefined-value? curr)) curr
                   (let ((val (valu-func)))
                     (safety (check-value loc val))
                     val ) ) ) ) )
    (dictbase-set! dict key val)
    val ) )

(define (+dict-update! dict key valu-func updt-func loc)
  (safety
    (check-dict loc dict)
    (check-procedure loc valu-func)
    (check-procedure loc updt-func) )
  (let* ((curr (dictbase-ref dict key (%undefined-value)))
         (updt (*dict-update! dict key valu-func updt-func curr loc)))
    (unless (%undefined-value? curr) (dict-bestfit dict))
    updt ) )

;; Dictionary Type

(define (dict-same-kind? dict1 dict2) (%eq? (dict-test-ref dict1) (dict-test-ref dict2)))
(define (dict-same-test? dict1 dict2) (%eq? (dictbase-test dict1) (dictbase-test dict2)))

(define (dict-bestfit dict)
	(if (%fx< MAGIC-LIMIT (dictbase-count dict))
      (unless (htable-dict? dict) (become-htable-dict! dict))
      (unless (alist-dict? dict) (become-alist-dict! dict)) ) )

;;; Globals

(define dict-safe-mode (make-parameter #t)) ;ignored!

(define (make-dict #!optional (test eq?) (size 0))
  (safety
    (check-cardinal-fixnum 'make-dict size "size")
    (check-procedure 'make-dict test) )
	(if (%fx< MAGIC-LIMIT size)
      (make-htable-dict test (make-hash-table test))
      (make-alist-dict test '())) )

(define (alist->dict al #!optional (test eq?) (size 0))
  (safety
    (check-alist 'alist->dict al "alist")
    (check-cardinal-fixnum 'alist->dict size "size")
    (check-procedure 'alist->dict test) )
	(if (or (%fx< MAGIC-LIMIT size) (%fx< MAGIC-LIMIT (%list-length al)))
      (make-htable-dict test (alist->hash-table al test))
      (make-alist-dict test al)) )

(define (dict->alist dict)
  (safety (check-dict 'dict->alist dict))
	(dictbase->alist dict) )

(define (dict-equivalence-function dict)
  (safety (check-dict 'dict-equivalence-function dict))
	(dictbase-test dict) )

(define (dict-count dict)
  (safety (check-dict 'dict-count dict))
	(dictbase-count dict) )

(define (dict-keys dict)
  (safety (check-dict 'dict-keys dict))
	(dictbase-keys dict) )

(define (dict-values dict)
  (safety (check-dict 'dict-values dict))
	(dictbase-values dict) )

(define (dict-ref dict key #!optional def)
  (safety (check-dict 'dict-ref dict))
	(dictbase-ref dict key def) )

(define (dict-set! dict key obj)
  (safety
    (check-value 'dict-set! obj)
    (check-dict 'dict-set! dict) )
	(dictbase-set! dict key obj)
	(dict-bestfit dict) )

(define (dict-exists? dict key)
  (safety (check-dict 'dict-exists? dict))
  (dictbase-exists? dict key) )

(define (dict-update! dict key valu-func #!optional (updt-func identity))
	(+dict-update! dict key valu-func updt-func 'dict-update!) )

(define (dict-update-list! dict key . vals)
  (+dict-update! dict key (lambda () '()) (cut fold cons <> (reverse! vals)) 'dict-update-list!) )

(define (dict-update-dict! dict key)
  (+dict-update! dict key (cut make-dict) identity 'dict-update-dict!) )

(define (dict-delete! dict key)
  (safety (check-dict 'dict-delete! dict))
	(dictbase-delete! dict key)
	(dict-bestfit dict) )

(define (dict-for-each dict proc)
  (safety
    (check-dict 'dict-for-each dict)
    (check-procedure 'dict-for-each proc) )
	(dictbase-for-each dict proc) )

(define (dict-search dict proc #!optional def)
  (safety
    (check-dict 'dict-search dict)
    (check-procedure 'dict-search proc) )
	(dictbase-search dict proc def) )

(define (dict-merge! dict . dicts)
  (safety (check-dict 'dict-merge! dict))
	(%list-for-each/1
		(lambda (dictx)
      (safety
        (check-dict 'dict-merge! dictx)
        (unless (dict-same-test? dict dictx)
          (error "cannot merge lookup-tables; incompatible test") ) )
			(if (dict-same-kind? dict dictx) (dictbase-merge! dict dictx)
          (dictbase-for-each dictx (cut dict-set! dict <> <>)) ) )
		dicts)
	(dict-bestfit dict) )

(define (dict-print dict #!optional port)
  (if (not port) (*dict-print dict)
      (with-output-to-port port (lambda () (*dict-print dict)) ) ) )