;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: User; -*-

#||                          DEFTABLE

===========================================================================
Copyright 1992 by Sun Microsystems Inc. (Sun)

Permission to use, copy, modify, and distribute this software and
its documentation for any purpose and without fee is hereby granted, 
provided that this copyright and permission notice appear in all
copies and supporting documentation.

Sun makes no representations about the suitability of this software
for any purpose.  It is provided "as is" without express or implied
warranty.  Sun disclaims all warranties, including all implied
warranties of merchantability and fitness. In no event shall Sun be
liable for any special, indirect or consequential damages or any
damages whatsoever resulting from loss of use, data or profits,
whether in an action of contract, negligence or other tortious
action, arising out of or in connection with the use or performance
of this software.
===========================================================================

The DEFTABLE macro provides a concise, lightweight notation for defining
tables: things you can put key/value pairs into, and retrieve the value
from the key.  For example, after specifying:

(deftable state
   :init '((AL Alabama) (AK Alaska) ...))

You can say (get-state 'AL) to get Alabama.  If the need ever arises, you 
can add to the table with (put-state 'PR 'Puerto-Rico), or equivalently,
(setf (get-state 'PR) 'Puerto-Rico).  You can delete one or clear all
entries, and you can use (map-state #'(lambda (abbrev name) ...)) to
map a function over all entries.

Finally, you can keep track of multiple tables of the same type.  For example,
you could arrange to have a table for each country, so that:
(get-state 'AZ *USA*) ==> Arizona
(get-state 'AZ *CIS*) ==> Azerbaijan

When it comes time to performance-tune your program, you can implement each 
table type as a hash table, property list, alist, or vector (if the keys
are dense small integers), or define your own implementation.

Note that if you evaluate two deftables with the same name, the table
created for the first one will not be replaced (because the table is
defined with defvar, not defparameter.  The default value and any initial
values will take effect the second (and subsequent) times, however.

See the article "DEFTABLE: A Macro for Implementing Tables"
by Peter Norvig, to appear in  Lisp Pointers, for more details.

;;;; Sample Expansion

(deftable state
   :init '((AL Alabama) (AK Alaska)))    ===>

(eval-when (eval compile load)
  (defun new-state-table (&key (size 100) (test #'equal))
    "Create a new table."
    (make-hash-table :test test :size size))
  (defparameter *state-table-default* nil)
  (defvar *state-table* (new-state-table))
  (declaim (notinline new-state-table get-state put-state rem-state map-state))
  (defsetf get-state (key &optional (table '*state-table*)) (val)
    (list 'put-state key val table))
  (defun get-state (key &optional (table *state-table*))
    "Return 2 values: the val for this key and t, or the default and nil."
    (gethash key table *state-table-default*))
  (defun put-state (key val &optional (table *state-table*))
    "Store val as the value of key in the table."
    (setf (gethash key table) val))
  (defun rem-state (key &optional (table *state-table*))
    "Remove key and it's value from the table."
    (remhash key table))
  (defun clear-state (&optional (table *state-table*))
    "Remove all key/value pairs from the table."
    (clrhash table))
  (defun map-state (fn &optional (table *state-table*))
    "Apply fn to each key and value, in any order."
    (maphash fn table))
  (initialize-table *state-table* #'put-state '((al alabama) (ak alaska)))
  'state)

||#

(in-package :cl-user)

;;;; DEFTABLE Macro
 
(defmacro deftable (name &rest args 
			 &key (type 'hash-table) inline default init
			 (tab (concatenate-symbols '* name '-table*))
			 (def (concatenate-symbols '* name '-table-default*))
			 (new (concatenate-symbols 'new- name '-table))
			 (put (concatenate-symbols 'put- name))
			 (get (concatenate-symbols 'get- name))
			 (clr (concatenate-symbols 'clear- name))
			 (map (concatenate-symbols 'map- name))
			 (rem (concatenate-symbols 'rem- name)) &allow-other-keys)
  "Define a table.  You can specify the type, whether the functions produced
  should be compiled inline or not, and the default value for the table.
  You can also specify the name of each function, and of the table and
  default-value variables (although we recommend using the default values:
  new-x, put-x, get-x, clr-x, map-x rem-x, *x-table* and *x-table-default*).
  You can also initialize the table with the :init keyword, which takes an
  alist of (key value) [NB: not (key . value}] pairs."
  (let ((code-list (apply (get-table-implementation type) name :def def args)))
    `(eval-when (eval compile load)
      (defun ,new (&key ,@(make-deftable-arglist code-list args))
	"Create a new table."
	,(code-for :new code-list))
      (defparameter ,def ,default)
      (defvar ,tab (,new))
      (declaim (,(if inline 'inline 'notinline) ,new ,get ,put ,rem ,map))
      (defsetf ,get (key &optional (table ',tab)) (val)
	(list ',put key val table))
      (defun ,get (key &optional (table ,tab)) 
	"Return 2 values: the val for this key and t, or the default and nil."
	,(code-for :get code-list))
      (defun ,put (key val &optional (table ,tab))
	"Store val as the value of key in the table."
	,(code-for :put code-list))
      (defun ,rem (key &optional (table ,tab))
	"Remove key and it's value from the table."
	,(code-for :rem code-list))
      (defun ,clr (&optional (table ,tab))
	"Remove all key/value pairs from the table."
	,(code-for :clr code-list))
      (defun ,map (fn &optional (table ,tab)) 
	"Apply fn to each key and value, in any order."
	,(code-for :map code-list))
      ,(when init
	 `(initialize-table ,tab #',put ,init))
      ',name)))

(defvar *table-implementations* nil)

(defmacro define-table-implementation (type arglist &body body)
  "Define an implementation of tables, giving the bodies of the
  six primitive operations."
  `(setf (getf *table-implementations* ',type)
    #'(lambda (name &key def ,@arglist &allow-other-keys)
	(list* :args ',arglist (progn ,@body)))))

(defun initialize-table (table put-fn initial-value-alist)
  "Initialize table (using the specified put-fn) with the
  alist of (key val) entries.  Note this is NOT (key . val)."
  (dolist (pair initial-value-alist)
    (funcall put-fn (first pair) (second pair) table))
  table)

;;;; Auxiliary Functions

(defun code-for (keyword code-list)
  "Return the code associated with this keyword, or signal an error."
  (if (get-member keyword code-list)
      (getf code-list keyword)
      (error "No ~a keyword supplied." keyword)))

(defun get-table-implementation (type)
  "Return the table implementation function for this type, or signal an error."
  (or (getf *table-implementations* type)
      (error "The type ~a should be one of ~{~s~*~^, ~}."
	     type *table-implementations*)))

(defun make-deftable-arglist (code-list deftable-args)
  "Given (deftable table :type type :size (* 10 n) :default 0) 
  and (define-table-implementation type ((test #'eql) (size 100))), 
  return ((test #'eql) (size (* 10 n)))."
  (labels ((var (pair) (if (symbolp pair) pair (first pair)))
	   (val (pair) (if (symbolp pair) nil (second pair)))
	   (arg-and-initval (pair)
	     (let* ((deftable-arg
			(get-member (intern (string (var pair)) :keyword)
				    deftable-args))) 
	       (list (var pair) (val (or deftable-arg pair))))))
    (mapcar #'arg-and-initval (getf code-list :args))))

(defun get-member (key plist)
  "Like member, returns a sublist of plist starting with key.
  But like get or getf, will only look for key in every other position.
  Example: (get-member 'c '(a one b two c three)) => (c three),
  Example: (get-member 'two '(a one b two c three)) => nil."
  (cond ((null plist) nil)
	((eql key (first plist)) plist)
	(t (get-member key (nthcdr 2 plist)))))


(defun getf2 (plist indicator &optional (default nil))
  "Like getf, but returns 2 values like gethash."
  (let ((rest-plist (get-member indicator plist)))
    (if rest-plist
	(values (second rest-plist) t)
	(values default nil))))

;;;; Table Implementations

;;; In addition to defining application-specific tables, you may want
;;; to specify the way to implement each table.  Do that by giving the
;;; :type keyword to deftable, with one of the values listed below:
;;; hash-table, vector, prop-list, alist or prop.  Or make up your own
;;; implementation with define-table-implementation.

(define-table-implementation hash-table ((size 100) (test #'equal))
  "The simplest implementation: hash tables.  O(1) access and update."
  `(:new (make-hash-table :test test :size size)
    :get (gethash key table ,def)
    :put (setf (gethash key table) val)
    :rem (remhash key table)
    :clr (clrhash table)
    :map (maphash fn table)))

(define-table-implementation vector ((size 100))
  "Requires that all keys are non-negative integers less than SIZE.
  Does not handle removing properly: all entries are present, and
  removing one just restores the default value.  O(1) access and update."
  `(:new (make-array size :initial-element ,def)
    :get (values (svref table key) t)
    :put (setf (svref table key) val)
    :rem (setf (svref table key) ,def)
    :clr (fill table ,def)
    :map (dotimes (i (length table))
	   (funcall fn i (svref table i)))))

(define-table-implementation prop-list ()
  "Keeps the table as a headed list, using getf.  O(n) access and update.
  Keys are compared with EQ."
  `(:new (cons ',name nil)
    :get (getf2 (rest table) key ,def)
    :put (setf (getf (rest table) key) val)
    :rem (remf (rest table) key)
    :clr (setf (rest table) nil)
    :map (loop for (key val) on (rest table) by #'cddr
	   do (funcall fn key val))))

(define-table-implementation alist ((test #'eql))
  "Very similar to prop-list, but in association list format."
  `(:new (cons ',name nil)
    :get (let ((pair (assoc key (rest table) :test ,test)))
	   (if pair
	       (values (cdr pair) t)
	       (values ,def nil)))
    :put (let ((pair (assoc key (rest table) :test ,test)))
	   (if pair
	       (setf (cdr pair) val)
	       (push (cons key val) (rest table)))
	   val)
    :rem (setf (rest table)
	  (delete key (rest table) :test ,test :key #'car))
    :clr (setf (rest table) nil)
    :map (dolist (pair (rest table))
	   (funcall fn (car pair) (cdr pair)))))

(define-table-implementation prop ((package *package*))
  "Keys must be symbols; values are stored under the name property.
  O(1) access (if no other properties), but MAP is O(#symbols in package)."
  `(:new package
    :get (getf2 (symbol-plist key) ',name ,def)
    :put (setf (get key ',name) val)
    :rem (remprop key ',name)
    :clr (do-symbols (key table)
	   (remprop key ',name))
    :map (do-symbols (key table)
	   (multiple-value-bind (val found?)
	       (getf2 (symbol-plist key) ',name)
	     (when found?
	       (funcall fn key (get key ',name)))))))

#|| 

;;;; Test Code

(defun test-it ()
  (every #'test-one '(hash-table alist prop vector prop-list)))

(defun test-one (type)
  (format t "~2&;; For ~a" type)
  (eval (copy-tree `(deftable sqr :type ,type :size 15)))
  (labels ((show-table (msg)
	     (format t "~&;; ~a:" msg)
	     (write *sqr-table* :array t)
	     (map-sqr #'print-kv))
	   (print-kv (k v) (format t "~&~a:~8T~a" k v))
	   (key (x) (if (eq type 'vector) x (concatenate-symbols 'x x))))

    (setf *sqr-table* (new-sqr-table))
    (loop for i from 1 to 10
	  do (setf (get-sqr (key i)) (* i i))
	  do (assert (eql (get-sqr (key i)) (* i i))))
    (show-table "After 10 entries")
    (clear-sqr)
    (show-table "After clearing")
    (put-sqr (key 1) 'one)
    (put-sqr (key 2) 'two)
    (put-sqr (key 3) 'three)
    (rem-sqr (key 1))
    (show-table "After adding 3 and rem-ing 1")
    (let ((new-tab (new-sqr-table)))
      (put-sqr (key 10) 'ten new-tab)
      (put-sqr (key 11) 'eleven new-tab)
      (put-sqr (key 12) '??? new-tab)
      (rem-sqr (key 12) new-tab)
      (format t "~&;; New-tab should have 10 and 11:")
      (map-sqr #'print-kv new-tab)
      (show-table "Now back to the original table")))
  t)

||#

;;; VK: added this function to simplify the
;;; interface.
(defun concatenate-symbols (&rest syms)
   (let ((str ""))
      (dolist (s syms)
         (setq str (concatenate 'string
                     str (symbol-name s))))
      (multiple-value-bind (x y)
          (read-from-string str)
         (declare (ignore y))
         x)))

