;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Associative database from Chapter 22 of Wilensky, "Common LISPcraft.

(defmacro add-to-data-base (item d-b-name)
  `(setq ,d-b-name (cons (replace-variables (quote ,item)) ,d-b-name)))

(defun replace-variables (item)
  (values (replace-variables-with-bindings item nil)))

(defun replace-variables-with-bindings (item bindings)
  (cond ((atom item) (values item bindings))
        ((pattern-var-p item)
          (let ((var-binding (get-binding item bindings)))
               (if var-binding
                 (values var-binding bindings)
                 (let ((newvar (makevar (gensym "VAR"))))
                    (values newvar (add-binding item newvar bindings))))))
        (t (multiple-value-bind (newlhs lhsbindings)
             (replace-variables-with-bindings (car item) bindings)
             (multiple-value-bind (newrhs finalbindings)
               (replace-variables-with-bindings (cdr item) lhsbindings)
               (values (cons newlhs newrhs) finalbindings))))))

(defun makevar (sym)
  (list '*var* sym))

(defun query (request data-base)
  (mapcan #'(lambda (item)
    (multiple-value-bind (flag bindings) (match item request)
       (if flag (list bindings))))
    data-base))

(defun index (item data-base)
  (let ((place (cond ((atom (car item)) (car item))
                     ((pattern-var-p (car item)) '*var*)
                     (t '*list*))))
       (setf (get place data-base)
             (cons (replace-variables item)
                   (get place data-base)))
       (setf (get data-base '*keys*)
             (adjoin place (get data-base '*keys*)))))

(defun fast-query (request data-base)
  (if (pattern-var-p (car request))
      (mapcan #'(lambda (key) (query request (get key data-base)))
              (get data-base '*keys*))
      (nconc
        (query request (get (if (atom (car request)) (car request) '*list*)
                            data-base))
        (query request (get '*var* data-base)))))

(defun retrieve (request data-base)
  (nconc (fast-query request data-base)
         (mapcan #'(lambda (bindings)
           (mapcar #'(lambda (rbindings) (append rbindings bindings))
              (retrieve (substitute-vars
                          (get-binding '?antecedent bindings)
                          bindings)
                        data-base)))
           (fast-query `(<- ,request ?antecedent) data-base))))

(defun substitute-vars (item bindings)
  (cond ((atom item) item)
        ((pattern-var-p item)
          (let ((binding (get-binding item bindings)))
               (if binding (substitute-vars binding bindings) item)))
        (t (cons (substitute-vars (car item) bindings)
                 (substitute-vars (cdr item) bindings)))))
