;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: kb-api-db.lsp
;;;;    System: 
;;;;    Author: Ken Forbus
;;;;   Created: January 3, 2004 20:46:48
;;;;   Purpose: Subset of KB API concerned with the KB qua database
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, May 31, 2004 at 18:27:04 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;; These procedures provide a layer over dbex, insulating FIRE from the
;;; details of how dbex works and providing the basic KB functionality.
;;; It contains procedures for:
;;;  Initializing DBEX
;;;  Creating, opening, and closing KB's
;;;  Storing, retrieving, and deleting from the KB

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Initialization

(defun init-dbex (&optional dll-path)
  (declare (ignore dll-path))
  "This function has been deprecated -- Allegro v6 has a better facility for
   loading DLLs and best of all, it requires no extra work on the part of
   you, the developer.  Therefore, there is no replacement for this function --
   just don't call it!"
  (warn "*** fire:init-dbex has been deprecated -- Allegro v6 has a better ~%~
         *** facility for loading DLLs and best of all, it requires no extra ~%~
         *** work on the part of you, the developer.  Therefore, there is no ~%~
         *** replacement for this function -- just don't call it!")
  :ok)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Setting up KB's

(defun db? (path name)
  (not (null (directory (merge-pathnames
                         (format nil "~A*.DBF" name) path)))))

(defun open-or-create-kb (&key (kb-path nil) (kb-name nil)
                               (new? nil) (force-update? nil)
                               (predicate-style :mixed-case))
  (cond ((and (null kb-path) (null kb-name))
         (if (fire:open-kb? *kb*)
             (in-kb (open-kb *kb*))
           (error "No open KB, please specify a path and name to a KB to open")))
        ((not (and kb-path kb-name))
         (error "You must specify both a path and a name"))
        (t
         (make-kb kb-path kb-name :new? new? :force-update? force-update?
                  :predicate-style predicate-style))))
  


(defun make-kb (path name &key (new? nil) 
                     (force-update? nil)
                     (predicate-style :mixed-case)
                     (corruption-check? :unspecified)
                     (recompute-cache? nil))
  "Sets up and opens a FIRE knowledge-base.  If corruption-check is non-nil,
   as error condition of type dbc:db-corrupt-error will be raised if the
   knowledge-base had not been properly closed when last used."
  (cond ((and fire:*kb*
              (not force-update?)
              (string-equal (path *kb*) path)
              (string-equal (name *kb*) name))
         (dbex:init-dbex (concatenate 'string 
                           (kb-resource-path *kb*) "BDLConfig.ini"))
         (in-kb (open-kb *kb*))
         *kb*)
        (t
         (kb-creation path name 
                      :new? new? 
                      :predicate-style predicate-style
                      :corruption-check? corruption-check?
                      :recompute-cache? recompute-cache?))))

(defun kb-creation (path name &key (new? nil)
                         (predicate-style :mixed-case)
                         (corruption-check? :unspecified)
                         (recompute-cache? nil))
  "Creates new KB in the directory denoted by <file-path>"
  (let ((kb (make-instance 'knowledge-base
              :path path
              :name name
              :predicate-style predicate-style)))
    (ensure-directories-exist path)
    (make-kb-resource-path-if-needed kb)
    ;; look for BDLConfig.ini in kb resources path
    (dbex:init-dbex (concatenate 'string (kb-resource-path kb) "BDLConfig.ini"))
    (cond (new?
           (when (db? path name)
             (delete-database path name))
           (setf (db kb) (dbex::create-db path name))
           (make-kb-metadata-file kb))
          ((not (db? path name))
           (setf (db kb) (dbex::create-db path name))
           (make-kb-metadata-file kb)))
    (in-kb (open-kb kb corruption-check?))
    (ensure-structural-cache-existence 
     kb :recompute-cache? recompute-cache?)
    kb))

(defun ensure-structural-cache-existence (kb &key (recompute-cache? nil))
  (cond (recompute-cache? 
         (recompute-structural-cache :kb kb)
         (dump-structural-cache :kb kb))
        (t 
         (load-structural-cache :kb kb)
         (unless (structural-cache? (structural-cache kb))
           (recompute-structural-cache :kb kb)
           (dump-structural-cache :kb kb)))))

#-unix
(defparameter *resource-subpath* "Resources\\")
#+unix
(defparameter *resource-subpath* "Resources/")
;; Parameterized in case of a future OS move

(defun kb-resource-path (&optional (kb *kb*))
  (concatenate 'string (path kb) *resource-subpath*))    

(defun make-kb-resource-path-if-needed (kb)
  (ensure-directories-exist (kb-resource-path kb)))

(defun make-kb-metadata-file (kb)
  (make-kb-resource-path-if-needed kb)
  (let ((fname (format nil "~A~A.info"
                            (kb-resource-path kb)
                            (name kb))))
    (with-open-file (fout fname
                            :direction :output
                            :if-exists :supersede)
      (format fout "(:path ~S :name ~S :predicate-style ~S)"
        (path kb) (name kb) (predicate-style kb)))))

(defun load-kb-metadata-file (path file-name)
  (let ((fname (concatenate 'string path *resource-subpath* file-name ".info")))
    (with-open-file (fin fname :direction :input)
      (let ((form (read fin))
            (ps :mixed-case))
        (do ((data form (cddr data))
             (key nil)
             (value nil))
            ((null data) ps)
          (setq key (car data)
              value (cadr data))
          (case key
            (:path nil)
            (:file-name nil)
            (:predicate-style (setq ps value))))))))
  
;;;;; 

(defun in-kb (kb) (setq *kb* kb))

;;; Moved to macros.lsp
;;; (defmacro with-kb (kb &rest forms)
;;;   `(let ((*kb* ,kb)) ,@ forms))

(defun open-kb (&optional (kb *kb*) (corruption-check? :unspecified)) 
  (unless (eq (state kb) :open)
    (setf (db kb) (dbex:connect-db (path kb) (name kb)
                                   :corruption-check? corruption-check?))
    (dbex:in-db (db kb))
    (setf (state kb) :open))
  kb)



(defun close-kb (&optional (kb *kb*))
  (mp:with-process-lock ((lock kb))
    (unless (eq (state kb) :closed)
      (dbex::disconnect-db (db kb))
      (setf (state kb) :closed))
    kb))

(defmethod open-kb? ((kb knowledge-base))
  (eq (state kb) :open))

(defmethod open-kb? (kb)
  (declare (ignore kb))
  nil)

(defun clear-kb (kb) 
  (delete-database (path kb) (name kb))
  (setf (state kb) :closed))

(defun delete-database (path name)
  ;; Wipe out existing contents
  ;; ***** Won't work if it is open.
  (dolist (fname (list-db-files path name))
    (delete-file fname))
  :done)

(defun list-db-files (path name)
  (nconc
   (directory (merge-pathnames (format nil "~A*.DBF" name) path))
   (directory (merge-pathnames (format nil "~A*.DBT" name) path))
   (directory (merge-pathnames (format nil "~A*.IND" name) path))))


;;; ***** N.B. load/dump procedures will be elsewhere.

(defun reset-kb-integrity-flags (kb-path kb-name)
  "Resets the counters used with DEBX's database corruption check."
  (dbex:reset-integrity-flags kb-path kb-name))

(defun rebuild-kb-indices (kb-path kb-name &key force-all? callback-fn)
  "Rebuilds the indices for those database files that are flagged as possibly
   corrupt.  If force-all? is non-nil, then ALL the indices will be rebuilt 
   regardless of the state of the corruption flags.  Note that the corruption 
   flags will only work properly if you have NOT call reset-kb-integrity-flags
   on your knowledge-base.  
   This function will reset the integrity flags as a side-effect of its 
   operation.  This function expects that the database files in the 
   knowledge-base are not currently open.  Furthermore, the KB will be in 
   a closed state when this function finishes.
   If callback-fn is provided, it will be called periodically with one 
   argument -- a number between 0 and 1 indicating the percentage complete."
  (dbex:rebuld-indices kb-path kb-name
                       :force-all? force-all?
                       :callback-fn callback-fn))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Storing, retrieving, and forgetting knowledge
;;
;; This part of the API is intended for everyday use in updating the KB.
;; It updates the structural cache appropriately with each statement
;; added to or deleted from the KB.
;; The metadata facility will be hooked into here.

(defvar *retrieve-coverage* :specs)

(defun kb-retrieve (exp &key (kb *kb*)
                        (number :all) (context :any)
                        (response :pattern) (coverage *retrieve-coverage*))
  ;; We don't track usage stats, so this is a pass-through.
  (retrieve exp :kb kb :number number :context context
            :response response :coverage coverage))

;; ****** Do we want to do a legal expression check on
;; ******  when storing?

(defun kb-store (exp &key (kb *kb*))
  (when (listp exp)
    (sc-update-add (car exp) (cdr exp) kb)
    (store exp kb)))

(defun kb-forget (exp &key (kb *kb*) (context :any)
                             (extent :exact))
  (sc-update-delete (car exp) (cdr exp) kb)
  (forget exp :kb kb :context context :extent extent))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Storing and retrieving knowledge -- internals.

(defun store (exp kb)
  (let ((result (store-no-testing exp kb)))
    (when (isa-statement? exp)
      ;; Don't cache in ltre unless other instances are:
      (when (and *reasoner*
                 (ltre::wm-retrieve (make-isa 'data::?x (third exp))
                           (ltre *reasoner*) 1 :bindings))
         (justify-kb-result-if-needed exp *reasoner*)))
    result))

(defun store-no-testing (exp kb)
  (mp:with-process-lock ((lock kb))
    (dbex:store-exp exp (db kb))))

;; SOLVE, QUERY and ASK eventually call RETRIEVE. The default value for
;; the :coverage argument is :specs, which is fine for most purposes, 
;; but for situations where one is making complex queries and wants to 
;; retrieve all patterns that unify with the form (or use retrieve in 
;; any other way), the macro with-retrieve-coverage allows us to lambda-bind
;; *retrieve-coverage* to a different value. - PKP 05/02/03

(defun global-context? (thing)
  (and (symbolp thing)
       (or (keywordp thing)
           (eq thing 'data::BaseKB))))


(defun retrieve-coverage-legal? (retrieve-coverage)
  (member retrieve-coverage '(:all :variants :specs :gens :ground :exact :raw :general)))

;;; (retrieve <pattern> :number <default 1, integer or :all>
;;;   :context <context. default :all>) 
;;; retrieves axioms matching <pattern>  in <kb>  within the
;;; specified context <context>.  The number of items returned
;;; depends on the :number keyword argument.

(defun retrieve (pattern &key (kb *kb*) (number :all) (context :any)
                         (response :pattern) (coverage *retrieve-coverage*)
                         (effort t))
  ;; If coverage has been explicitly passed, then that supercedes *retrieve-coverage*.
  ;; If not, and *retrieve-coverage* is bound to a legal value, then we use that, or 
  ;; we default to :specs. Please report if it causes any problem -- PKP 05/02/03  
  (cond ((eql coverage :general)
         (retrieve-general pattern :kb kb :number number :context context :response response))        
        (t (let* ((*retrieve-coverage* (if (not (retrieve-coverage-legal? coverage))
                                         (if (not (retrieve-coverage-legal? *retrieve-coverage*))
                                           :specs
                                           *retrieve-coverage*)
                                         coverage))
                  (contextualized? (not (global-context? context)))
                  (contextualized-pattern
                   (if contextualized? (make-case-fact context pattern)
                     pattern))
                  (db-results (prune-number-of-results 
                               ;; ***** lookup-exp probably should be doing this
                               ;; ***** length pruning internally.
                               (nconc
                                (mp:with-process-lock ((lock kb))
                                  (dbex::lookup-exp contextualized-pattern
                                                    *retrieve-coverage* :pointers (db kb)))
                                (if (and contextualized? (not (eq effort :local-only)))
                                  (mp::with-process-lock ((lock kb))
                                    (dbex::lookup-exp pattern
                                                      *retrieve-coverage* :pointers (db kb)))))
                               number)))
             ;; Each result of the form (form length record-ID bindings)
             (case response
               (:bindings (mapcar 'fourth db-results))
               (:pattern (mapcar #'(lambda (result)
                                    (car result)) db-results))
               (t (mapcar #'(lambda (db-result)
                              (sublis (fourth db-result) response))           
                    db-results)))))))

;;; Added 8/8/03 (TRH)
;;; This is guaranteed not to uniquify the patterns returned.  The only caveat is that
;;; it doesn't take a :response argument and never returns a binding list.
(defun retrieve-pattern (pattern &key (kb *kb*) (number :all)
                                 (coverage *retrieve-coverage*) (context :any))
  (declare (ignore context))
  (let ((*retrieve-coverage* (if (not (retrieve-coverage-legal? coverage))
                               (if (not (retrieve-coverage-legal? *retrieve-coverage*))
                                 :specs
                                 *retrieve-coverage*)
                               coverage)))
    (unless (and (integerp number) (plusp number))
      (setf number nil))
    (mp:with-process-lock ((lock kb))
      (dbex::lookup-exp pattern *retrieve-coverage* :instances (db kb) t number))))

;;; Added 01/02/04 (PKP)
;; This allows us to retrieve more general forms from the KB (those that have more variables
;; the input form) without doing full-fledged unification (which :coverage of :raw does). 

(defun retrieve-general (form &key (kb *kb*) (number :all) (context :any)
                              (response :pattern))
  (let* ((generalized-form (generalize-form form))
         (retrieve-results (retrieve-pattern
                            generalized-form
                            :kb kb :number number :context context :coverage :specs))
         (results nil))
    (dolist (retrieve-result retrieve-results)
      (let ((unifier (ltre::unify form retrieve-result)))
        (if (not (eql unifier :fail))
          (push unifier results))))
    (case response 
      (:bindings (values results))
      (:pattern (mapcar #'(lambda (result)
                            (sublis result form)) results))
      (t (mapcar #'(lambda (result)
                     (sublis result response)) results)))))

(defun generalize-form (form)
  "Return a list that has variables in all positions except for the first"
  (let ((generalized-form nil)
        (num-vars (1- (length form))))
    (push (car form) generalized-form)
    (dotimes (i num-vars)
      (push (intern (format nil "?~A" i)) generalized-form))
    (setq generalized-form (nreverse generalized-form))
    (return-from generalize-form generalized-form)))

(defun prune-number-of-results (results limit)
  ;; N.B. You really really don't want to let BUTLAST get a non-numerical
  ;; second argument.  It can cause Lisp to die hideously.
  (cond ((and (numberp limit)
              (integerp limit)
              (> limit 0))
         (let ((l (length results)))
           (if (> l limit) (nbutlast results (- l limit))
             results)))
        (t results)))

(defun retrieve-all (pattern &key (kb *kb*) (context :any) (coverage :specs))
  (retrieve pattern :kb kb :context context :number :all :coverage coverage))  
  
(defun retrieve-references (exp &key (kb *kb*) (context :any))
  (declare (ignore context))  ;; for now anyway
  (mapcar #'car
    (mp:with-process-lock ((lock kb))
      (dbex::super-exp exp t :ground :pointers (db kb)))))

(defun retrieve-isas (entity &key (kb *kb*))
  (let ((entry (find-sc-entry entity kb)))
    (when (sc-entry? entry)
      (mapcar 'sc-item (sc-isas entry)))))

(defun fetch-isas (entity &key (reasoner *reasoner*))
  (let ((wm-isas (mapcar 'third
                   (ltre::fetch-trues `(data::isa ,entity ?x) (ltre reasoner))))
        (kb-isas (retrieve-isas entity :kb (kb reasoner))))
    (remove-duplicates (nconc wm-isas kb-isas) :test 'equal)))
;;;
;;; Symmetric retrieval:
;;; ***** Exercise for the reader: Extend the structural cache to handle this, too.

(defun symmetric-retrieve (query &key (kb *kb*) (number :all) (context :any)
                                 (response :bindings)
                                 (effort :lots)
                                 (coverage *retrieve-coverage*))
  (let* ((results (mapcar #'(lambda (r) (cons query r))
                    (retrieve query :kb kb :context context :coverage coverage
                              :number number :response response
                              :effort effort)))
         (remaining (if (integerp number) (- number (length results)) number)))
    (cond ((and (symmetric-binary-pred (first query))
                (or (not (integerp number))
                    (< (length results) number)))
           (setq query (swap-args query))
           (nconc results (mapcar #'(lambda (r) (cons query r))
                            (retrieve query :kb kb :context context
                                      :coverage coverage :number remaining 
                                      :response response))))
          (t results))))

;;; use retrieve-isas because it checks the cache first:
(defun symmetric-binary-pred (pred &key (kb *kb*))
  (member (if (mixed-case?) 
            'data::SymmetricBinaryPredicate
            'data::symmetric-binary-predicate)
          (retrieve-isas pred :kb kb)))

(defun swap-args (binrel)
  (list (first binrel) (third binrel) (second binrel)))

(defgeneric complete-from-KB (sub-symb &key filter)
  (:documentation "Returns a list of possible completions for symbol from the KB constrained by the filter
    function passed in (which is a function of one argument - the possible completion - if filter returns T
    this completion will be reported, if it returns False, the completion will be filtered. defaults to returning
    all possible completions)"))

#-unix
(defmethod complete-from-KB ((sub-symb string) &key (filter #'identity))
  (complete-from-KB (cg:read-from-string-safely sub-symb) :filter filter))

        
(defmethod complete-from-KB ((sub-symb symbol) &key (filter #'(lambda (comp) 
                                                                (declare (ignore comp))
                                                                t)))
  (let ((completions (dbex:symbol-complete sub-symb)))
    (remove-if-not filter completions)))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Deleting knowledge

(defun forget (expression &key (kb *kb*) (context :any)
                          (extent :exact))
  ;; :extent is a keyword to dbex.  Possibilities are
  ;; :exact, :variants, :specs, :all, and :ground
  ;; see dbex file del-expr.lsp for documentation on what these do.
  ;; To nuke everything that matches a pattern, use :all.
  (declare (ignore context))
  (mp:with-process-lock ((lock kb))
    (dbex::delete-exp expression extent (db kb)))
  (let ((asn-form (make-in-kb-statement expression)))
    (when (and *reasoner* (ltre::true? asn-form))
      (untell asn-form *reasoner* :kb-lookup :all))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Documentation

(defmethod get-documentation ((pred symbol) (kb knowledge-base))
  ;; Doc-strings should be asserted using make-comment-statement,
  ;; but some of our earlier KBs used make-documentation instead.
  ;; This is not quite correct, so all newer KBs must use
  ;; make-comment-statement.
  (or (first (retrieve (make-comment-statement pred '?x)
                       :kb kb :coverage :ground :number 1
                       :response '?x))
      (first (retrieve (make-documentation pred '?x)
                       :kb kb :coverage :ground :number 1
                       :response '?x))))

(defmethod get-documentation ((nat cons) (kb knowledge-base))
  (or (first (retrieve (make-comment-statement nat '?x)
                       :kb kb :coverage :ground :number 1
                       :response '?x))
      (first (retrieve (make-documentation nat '?x)
                       :kb kb :coverage :ground :number 1
                       :response '?x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Recovering from indexing problems

(defun rebuild-BDL-index (path fname &optional (verbose? t))
  (let ((the-program (concatenate 'string dbex::*bdl-bin-path* "BDLFix.exe")))
    (dolist (dbf-file (directory (concatenate 'string path fname "*.DBF")))
      (when verbose? (format t "~% Rebuilding index for ~A" dbf-file))
      (excl:run-shell-command (format nil "~A ~A" the-program dbf-file)
                                :wait t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Testing

;;; Test KB

(defparameter *test-kb-path* #+unix (concatenate 'string *fire-path* "Tests/KB/")
  #-unix(concatenate 'string *fire-path* "Tests\\KB\\"))
(defparameter *test-kb-name* "fire-test-kb")
(defparameter data::*instances* nil)

(defun make-test-kb () (make-kb *test-kb-path* *test-kb-name* 
                                :new? t
                                :predicate-style :hyphen))

(defun collection-cardinality (collection)
  (setq data::*instances* 
        (ask `(data::isa ?x ,collection) *reasoner* :every :exhaustive '?x :max))
  (length data::*instances*))

(defun list-collections ()
  (let ((isas (retrieve '(data::isa ?x ?col)))
        (collections nil))
    (dolist (isa isas collections)
      (pushnew (caddr isa) collections
               :test 'equal))))


;; All individuals in QRG-DARPA as of 2/27/03: 46,868
;; All collections in QRG-DARPA as of 2/27/03: 3,006

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global operations

(defun map-over-kb (procedure kb)
  (dbex::map-complete-database procedure (fire::db kb)))

(defvar *predicate-distribution-table* nil "For statistics")

(defun kb-statistics (kb &optional (stream *standard-output*))
  (let ((table nil)
        (n-forms 0)
        (n-ground 0)
        (random 0))
    (time ;; Record time as cheap way of keeping an eye on caching
     (map-over-kb #'(lambda (form)
                     (cond ((not (listp form)) (incf random))
                           (t (incf n-forms)
                              (when (ground-formula? form) (incf n-ground))
                              (let ((entry (assoc (car form) table
                                                  :test 'equal)))
                                (unless entry
                                  (push (setq entry (cons (car form) 0)) table))
                                (incf (cdr entry))))))
                  kb))
    (format stream "~%For knowledge base ~A:" (name kb))
    (format stream "~% ~D axioms, ~D of which are ground.  ~A"
      n-forms n-ground (if (> random 0) (format nil "Also ~D non-list entries." random)
                         ""))
    (outline-kb-statistics table stream)
    (format stream "~% For details please see fire::*predicate-distribution-table*.")
    (setq *predicate-distribution-table* table)
    n-forms))

(defun outline-kb-statistics (table stream)
  ;; Table is an alist of (predicate . # of occurrences)
  (format stream "~% ~D predicates total." (length table))
  (let ((min-occurs 10000000)
        (max-occurs 0)
        (the-max nil)
        (the-min nil)
        (n-singletons 0))
    (dolist (entry table)
      (when (= (cdr entry) max-occurs)
        (push (car entry) the-max))
      (when (= (cdr entry) min-occurs)
        (push (car entry) the-min))
      (when (> (cdr entry) max-occurs)
        (setq max-occurs (cdr entry)
            the-max (list (car entry))))
      (when (< (cdr entry) min-occurs)
        (setq min-occurs (cdr entry)
            the-min (list (car entry))))
      (if (= (cdr entry) 1) (incf n-singletons)))
    (format stream "~% Maximum statements = ~D, for ~A."
      max-occurs the-max)
    (format stream "~% Minimum statements = ~D, for ~A."
      min-occurs the-min)
    (if (> n-singletons 0) 
      (format stream "~%  ~D predicates are heads in only one global statement."
        n-singletons))))
    

      

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code