;;;; lookup-table.scm
;;;; Kon Lovett, Apr '09

(declare
  (usual-integrations)
  (disable-interrupts)
  (fixnum)
  (inline)
  (local)
  (no-procedure-checks) )

;;;

;; Element count when hash-table faster
;; (your milage may vary)

(define-constant MAGIC-LIMIT 12)

;;

(module lookup-table (;export
  dict-safe-mode
  make-dict
  alist->dict
  dict->alist
  dict?
  dict-equivalence-function
  dict-count
  dict-keys
  dict-values
  dict-ref
  dict-set!
  dict-exists?
  dict-update!
  dict-update-list!
  dict-update-dict!
  dict-delete!
  dict-for-each
  dict-search
  dict-merge!
  dict-print )

(import scheme chicken srfi-1 srfi-69 ports data-structures extras miscmacros type-checks type-errors)
(require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors)

;;;

(define (alist-find proc al #!optional def)
	(let loop ((al al))
		(if (null? al) def
        (let* ((cell (car al))
               (val (cdr cell)))
            (if (proc (car cell) val) val
                (loop (cdr al)) ) ) ) ) )

;;; Variant Dictionary

(define-record-type 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 )

(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! 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?) )

;; 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)) ) )

;; Argument Checks

(define-check-type dict)

(define (check-value loc obj)
  (when (eq? (void) obj) (error-argument-type loc obj "non-undefined value")) )

;;;

;; Argument validation & literal object return.

(define *dict-safe-mode* #f)

;;; Alist Dictionary

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

(define (alist-dict->alist data)
  (let ((dat (alist-dict-alist data)))
    (if *dict-safe-mode* (list-copy dat)
        dat ) ) )

(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)
	(for-each (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)))
		(for-each (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) (length (alist-dict-alist data)))

(define (alist-dict-keys data) (map (lambda (x) (car x)) (alist-dict-alist data)))

(define (alist-dict-values data) (map (lambda (x) (cdr x)) (alist-dict-alist data)))

(define (alist-dict-exists? data key)
	(not (eq? (void) (alist-dict-ref data key (void)))) )

(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) (dict->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 (dict->alist dict) test))))
	(set-htable-dict-procs! dict) )

;; Errors

(define-error-type dict)

;;

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

(define (*dict-update! dict key valu-func updt-func curr loc)
  (let ((val (updt-func
              (if (not (eq? (void) curr)) curr
                  (let ((val (valu-func)))
                    (when *dict-safe-mode* (check-value loc val))
                    val ) ) ) ) )
    (dictbase-set! dict key val)
    val ) )

(define (+dict-update! dict key valu-func updt-func loc)
  (when *dict-safe-mode*
    (check-dict loc dict)
    (check-procedure loc valu-func)
    (check-procedure loc updt-func) )
  (let* ((curr (dictbase-ref dict key (void)))
         (updt (*dict-update! dict key valu-func updt-func curr loc)))
    (unless (eq? (void) curr) (dict-bestfit dict))
    updt ) )

;;; Globals

(define-parameter dict-safe-mode *dict-safe-mode*
  (lambda (x)
    (set! *dict-safe-mode* x)
    x))

(define (make-dict #!optional (test eq?) (size 0))
  (when *dict-safe-mode*
    (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))
  (when *dict-safe-mode*
    (check-cardinal-fixnum 'alist->dict size "size")
    (check-procedure 'alist->dict test) )
	(if (or (fx< MAGIC-LIMIT size) (fx< MAGIC-LIMIT (length al)))
      (make-htable-dict test (alist->hash-table al test))
      (make-alist-dict test al)) )

(define (dict->alist dict)
  (when *dict-safe-mode* (check-dict 'dict->alist dict))
	(dictbase->alist dict) )

(define (dict-equivalence-function dict)
  (when *dict-safe-mode* (check-dict 'dict-equivalence-function dict))
	(dictbase-test dict) )

(define (dict-count dict)
  (when *dict-safe-mode* (check-dict 'dict-count dict))
	(dictbase-count dict) )

(define (dict-keys dict)
  (when *dict-safe-mode* (check-dict 'dict-keys dict))
	(dictbase-keys dict) )

(define (dict-values dict)
  (when *dict-safe-mode* (check-dict 'dict-values dict))
	(dictbase-values dict) )

(define (dict-ref dict key #!optional def)
  (when *dict-safe-mode* (check-dict 'dict-ref dict))
	(dictbase-ref dict key def) )

(define (dict-set! dict key obj)
  (when *dict-safe-mode*
    (check-value 'dict-set! obj)
    (check-dict 'dict-set! dict) )
	(dictbase-set! dict key obj)
	(dict-bestfit dict) )

(define (dict-exists? dict key)
  (when *dict-safe-mode* (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)
  (when *dict-safe-mode* (check-dict 'dict-delete! dict))
	(dictbase-delete! dict key)
	(dict-bestfit dict) )

(define (dict-for-each dict proc)
  (when *dict-safe-mode*
    (check-dict 'dict-for-each dict)
    (check-procedure 'dict-for-each proc) )
	(dictbase-for-each dict proc) )

(define (dict-search dict proc #!optional def)
  (when *dict-safe-mode*
    (check-dict 'dict-search dict)
    (check-procedure 'dict-search proc) )
	(dictbase-search dict proc def) )

(define (dict-merge! dict . dicts)
  (when *dict-safe-mode* (check-dict 'dict-merge! dict))
	(for-each
		(lambda (dictx)
      (when *dict-safe-mode*
        (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)) ) ) )

) ;module lookup-table