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

(import (only srfi-1 reverse! fold list-copy find alist-delete!)
        (only srfi-69 hash-table->alist hash-table-ref/default hash-table-set!
                      hash-table-delete! hash-table-for-each hash-table-merge!
                      hash-table-walk hash-table-size hash-table-keys hash-table-values
                      hash-table-exists? alist->hash-table make-hash-table)
        (only ports with-output-to-port)
        (only data-structures identity alist-ref alist-update!)
        (only extras pretty-print)
        (only miscmacros let/cc)
        type-checks
        type-errors)

(require-library srfi-1 srfi-69 extras miscmacros type-checks type-errors
                 ;get some core unit to handle srfi-69 as builtin bug
                 lolevel)

;;;

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

;;;

(cond-expand

  (unsafe
    (import srfi-9-ext)
    (require-library srfi-9-ext)

    (include "chicken-primitive-object-inlines")

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

  (else
    (define (%undefined-value? obj) (eq? (void) obj))
    (define (%undefined-value) (void))
    (define %list-map/1 map)
    (define %list-for-each/1 for-each)
    (define %list-length length)
    (define %list-find find)
    (define %fx< fx<)
    (define %eq? eq?)
    (define %alist-delete! alist-delete!)
    (define %alist-update! alist-update!)
    (define %alist-ref alist-ref)
    (define %list-copy list-copy)
    (define %set-cdr! set-cdr!)
    (define %cons cons)
    (define %cdr cdr)
    (define %car car)

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

; 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 (alist-search al proc #!optional def)
  (let ((cell (%list-find (lambda (cell) (proc (%car cell) (%cdr cell))) al)))
    (if cell (%cdr cell)
        def ) ) )

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

;;;

;;; 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-search (alist-dict-alist data) proc 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 "defined value" nam)) )

;; 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! loc dict key valu-func updt-func)

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

  (safety
    (check-dict loc dict)
    (check-procedure loc valu-func)
    (check-procedure loc updt-func) )
  (*dict-update! (dictbase-ref dict key (%undefined-value))) )

;; 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-indempotent-ref! dict key func #!optional def)
  (safety
    (check-dict 'dict-indempotent-ref! dict)
    (check-procedure 'dict-indempotent-ref! func) )
  (let ((val (dictbase-ref dict key def)))
    (if (not (eq? def val)) val
        (let ((val (func def)))
          (if (eq? def val) def
              (begin
                (dictbase-set! dict key val)
                (dict-bestfit dict)
                val ) ) ) ) ) )

(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-update! dict key valu-func updt-func) )

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

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

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