;; -*- Mode: Lisp; -*-

;;; Database for Tiny Rule Engine

;;; Copyright (c) 1986-1992, Kenneth D. Forbus, Northwestern University,
;;; and Johan de Kleer, the Xerox Corporation.
;;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

(in-package :cl-user)

;; This simple version uses "car indexing" to store facts and rules
;; which might match.  Unification provides the actual matching.

(defvar *env* nil)

(defstruct (dbclass (:print-function dbclass-print-procedure))
     name		;a symbol
     tre                ;The tre it belongs to
     facts		;facts of this dbclass
     rules)		;rules applicable to this dbclass

(defun dbclass-print-procedure (d strm ignore)
  (declare (ignore ignore))
  (format strm "<Dbclass ~D>" (dbclass-name d)))

(defun show-data (&optional (stream *standard-output*) &aux counter)
  (setq counter 0)
  (maphash #'(lambda (key dbclass)
               (declare (ignore key))
               (dolist (datum (dbclass-facts dbclass))
		       (incf counter)
		       (format stream "~%~A" datum)))
	   (tre-dbclass-table *tre*))
  counter)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Installing new facts

(defun assert! (fact &optional (*tre* *tre*))
   "Assert a fact in the database, and run appropriate rules on it if needed."
   (when (insert fact *tre*)  ;; when it isn't already there
     (try-rules fact *tre*))) ;; run the rules on it.

(defun insert (fact tre &aux dbclass)
   "Insert a single fact into the database."
   (setq dbclass (get-dbclass fact tre)) ;Question: Why not use PUSHNEW here?
   (unless (member fact (dbclass-facts dbclass) :test #'equal)
      (debugging-tre "~% ~A: Inserting ~A into database." tre fact)
      (push fact (dbclass-facts dbclass))))

(defun get-dbclass (fact tre &aux dbclass val)
   "Retrieve a single dbclass for a given fact or symbol."
   (cond ((listp fact) (get-dbclass (car fact) tre))
         ((variable? fact)
          ;; We might be in the environment of some rule, so must
          ;; check the variable's bindings.
          (cond ((boundp fact) (get-dbclass (symbol-value fact) tre))
                ((setq val (assoc fact *env*))
                 (get-dbclass (cdr val) tre))
                (t (error "~%Dbclass unbound: ~A" fact))))
         ((symbolp fact)
          (cond ((setq dbclass (gethash fact (tre-dbclass-table tre))) dbclass)
                ;; Nothing found, so build it.
                (t (setq dbclass (make-dbclass :name fact :tre tre
                                   :facts nil :rules nil))
                  (setf (gethash fact (tre-dbclass-table tre)) dbclass)
                  dbclass)))
         (t (error "Bad dbclass type: ~A" fact))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Fetching data

(defun fetch (pattern &optional (tre *tre*) &aux bindings unifiers)
  "Returns the list of facts which unify with the pattern."
  (dolist (candidate (get-candidates pattern tre) unifiers)
    (setq bindings (unify pattern candidate))
    (unless (eq bindings :fail)
      (push (sublis bindings pattern) unifiers))))

(defun get-candidates (pattern tre)
   "Retrieve all facts from the dbclass of a given pattern."
   (dbclass-facts (get-dbclass pattern tre)))