;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: kb-api.lsp
;;;;    System: FIRE
;;;;   Version: 1.0
;;;;    Author: Ken Forbus
;;;;   Created: November 13, 2000 21:18:54
;;;;   Purpose: Basic KB API procedures
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Saturday, January 3, 2004 at 13:36:53 by paritosh
;;;; ---------------------------------------------------------------------------

(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
;;;  Queries regarding collections and the genls graph
;;;  Accessing information about predicates

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; 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))
  "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))
         (in-kb (open-kb *kb*))
         *kb*)
        (t
         (kb-creation path name 
                      :new? new? 
                      :predicate-style predicate-style
                      :corruption-check? corruption-check?))))

(defun kb-creation (path name &key (new? nil)
                                   (predicate-style :mixed-case)
                                   (corruption-check? :unspecified))
  "Creates new KB in the directory denoted by <file-path>"
  (let ((kb (make-instance 'knowledge-base
              :path path
              :name name
              :sme-predicate-cache (make-hash-table :test 'equal)
              :predicate-style predicate-style)))
    (ensure-directories-exist path)
    (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?))
    (update-genls-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 (directory (merge-pathnames 
                             (format nil "~A*" name) path)))
    (delete-file fname)))

;;; ***** 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 and retrieving knowledge

(defun store (exp kb)
  (let ((result (store-no-testing exp kb)))
    (when (constant-genls-statement? exp)
      ;; Clear genls cache for safety
      (reset-genls-cache kb)
      ;; Mark files as stale
      (mark-genls-cache-files-stale kb))
    (when (isa-statement? exp)
      (unless (null (gethash (cadr exp) (isa-cache kb)))
        (setf (gethash (cadr exp) (isa-cache kb))
          (retrieve-isas-doit (cadr exp) :kb kb)))
      ;; 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

(defvar *retrieve-coverage* :specs)

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

;; ***** N.B. Context argument not used yet.  We still haven't converged on 
;; what we should do re domain theory versus microtheory organization

(defun retrieve (pattern &key (kb *kb*) (number :all) (context :any)
                         (response :pattern) (coverage *retrieve-coverage*))
  (declare (ignore context)) ;; for now anyway
  ;; 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))
                  (db-results (prune-number-of-results 
                               ;; ***** lookup-exp probably should be doing this
                               ;; ***** length pruning internally.
                               (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 'car db-results))
               (t (mapcar #'(lambda (db-result)
                              (sublis (fourth db-result) response))           
                    db-results)))))))

;;; 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 retrieve-result form)))
        (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)))

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

(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*))
  (unless (variable? entity) ;; Ban (isa ?x ?col) lookups!
    (let ((cached (gethash entity (isa-cache kb))))
      (cond ((null cached)
             (setq cached (retrieve-isas-doit entity :kb kb))
             (setf (gethash entity (isa-cache kb))
               (if cached cached :NONE))
             cached)
            ((eq cached :NONE) nil)
            (t cached)))))

(defun retrieve-isas-doit (entity &key (kb *kb*))
  (retrieve `(data::isa ,entity ?col) :kb kb
            :response '?col
            :coverage :ground))

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

;;; This internal version is SLOWER with either the top-down being t or nil!
;;; (defun retrieve-isas (entity &key (kb *kb*))
;;;   (mapcar #'(lambda (dbex-result)
;;;               (third (car dbex-result)))
;;;     (dbex::lookup-aux (db kb) 3 `(data::isa ,entity ?col) t :ground :top-down t)))


;;;
;;; Symmetric retrieval:
;;;

(defun symmetric-retrieve (query &key (kb *kb*) (number :all) (context :any)
                                   (response :bindings) (coverage *retrieve-coverage*))
  (let* ((results (mapcar #'(lambda (r) (cons query r))
                    (retrieve query :kb kb :context context :coverage coverage
                              :number number :response response)))
         (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))
  (when (genls-statement? expression)
    ;; We don't know how many genls statements got retracted,
    ;; in the case where expression has pattern variables, but
    ;; we reset the whole cache anyway.
    (reset-genls-cache *kb*)
    ;; Mark files as stale
    (mark-genls-cache-files-stale kb))
  (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))
    (when (isa-statement? expression)
      (unless (null (gethash (cadr expression) (isa-cache kb)))
        (setf (gethash (cadr expression) (isa-cache kb))
              (retrieve-isas-doit (cadr expression) :kb kb))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Structural operations

;; We use the genls cache extensively here.  Since the
;; genls cache is taking around 20 seconds to create on
;; an IKB-sized KB, we should probably start storing that
;; with the KB and reloading rather than recomputing.

(defun collection? (thing &key (kb *kb*))
  ;; the if statement below insulations applications from some of the
  ;; inner workings of the genls cache tables.
  ;; N.B. Got rid of instance-of collection test because that just
  ;; resulted in genls cache entries being created that were actually
  ;; not appropriate.  
  (if (or (exists-in-low-level-genls-tables? thing kb)
          (and (non-atomic-term? thing)
               (instance-of?-simple
                (car thing) 
                (if (mixed-case? kb)
                  'data::CollectionDenotingFunction
                  'data::collection-denoting-function))))
    t nil))

(defun collection?-simple (thing &key (kb *kb*))
  (exists-in-low-level-genls-tables? thing kb))

(defun collections-of (entity) (retrieve-isas entity :kb *kb*))

(defun list-all-collections (&key (kb *kb*) (include-nats? nil))
  "Returns an unordered list of all the collections in the KB.  This is not
   fast, so it is mostly useful only for debugging and some user-interface
   needs."
  (let ((genls-cache (genls-cache kb))
        (cols nil))
    ;; This get all but the top-level collections ...
    (maphash #'(lambda (key val)
                 (declare (ignore val))
                 (when (or include-nats? (symbolp key))
                   (push key cols)))
             (direct-genls genls-cache))
    ;; Now for an annoying step -- we also need to looks at the direct-subs
    ;; cache in order to catch those few top-level collections.  Since this
    ;; includes mostly duplicates of what was already pushed onto cols, we
    ;; need to do the moral equivalent of union.
    (maphash #'(lambda (key val)
                 (declare (ignore val))
                 (if include-nats?
                   (pushnew key cols :test #'equal)
                   (when (symbolp key)
                     (pushnew key cols :test #'eq))))
             (direct-subs genls-cache))
    cols))

(defun map-collections (procedure &key (kb *kb*))
  "Applies PROCEDURE to every collection in KB."
  (let ((cache (genls-cache kb)))
    ;; The direct subs and direct genls tables have
    ;; all the collections in them, by design.
    ;; [Um.  If there are no connections at all will
    ;; we have them in here?]
    ;; Since some collections have no subs (leaves)
    ;; and other collections have no genls (roots),
    ;; we have to look at both tables.  But in looking
    ;; at the second table, we can ignore an entry if 
    ;; it appears in the first table.
    (maphash #'(lambda (key val)
                 (declare (ignore val))
                 (funcall procedure key))
             (direct-subs cache))
    (maphash #'(lambda (key val)
                 (declare (ignore val))
                 (unless (gethash key (direct-subs cache))
                   (funcall procedure key)))
             (direct-genls cache))))
    
(defun subset-of? (subcol supercol &key (kb *kb*))
  (or (eq subcol supercol)
      (when (and (collection? subcol)
                 (collection? supercol))
        ;; Do the quick check for collectionhood to avoid
        ;; adding inappropriate stuff to the genls cache.
      (let* ((entry (genls-cache-entry subcol kb)))
        (when (and entry (listp (allgenls entry)))
          (member supercol (allgenls entry)
                  :key 'predicate :test 'equal))))))

(defun instance-of? (entity collection &key (kb *kb*)
                            (reasoner *reasoner*))
  (when (collection? collection)
    (some #'(lambda (col)
              (or (eq col collection)
                  (when (collection? col)
                    (let ((entry (genls-cache-entry col kb)))
                      (when (and entry (listp (allgenls entry)))
                        (member collection (allgenls entry)
                                :key 'predicate :test 'equal))))))
          (if (reasoner? reasoner)
            (fetch-isas entity :reasoner reasoner)
            (retrieve-isas entity :kb kb)))))

(defun instance-of?-simple (entity collection &key (kb *kb*)
                                   (reasoner *reasoner*))
  (when (collection?-simple collection)
    (some #'(lambda (col)
              (or (eq col collection)
                  (when (collection?-simple col)
                    (let ((entry (genls-cache-entry col kb)))
                      (when (and entry (listp (allgenls entry)))
                        (member collection (allgenls entry)
                                :key 'predicate :test 'equal))))))
          (if (reasoner? reasoner)
            (fetch-isas entity :reasoner reasoner)
            (retrieve-isas entity :kb kb)))))

(defun instance-of-any? (entity collections &key (kb *kb*))
  (some #'(lambda (col)
            (or (member col collections :test 'equal)
                (when (collection? col)
                  (let* ((entry (genls-cache-entry col kb)))
                    (when (and entry (listp (allgenls entry)))
                      (some #'(lambda (collection)
                                (member collection (allgenls entry)
                                        :key 'predicate :test 'equal))
                            collections))))))
        (retrieve-isas entity :kb kb)))
  
;; These operations don't return antecedents because they are 
;; intended for lightweight operations

(defun immediate-genls (collection &key (kb *kb*))
  (when (collection? collection)
    (retrieve-genls collection (genls-cache kb))))

(defun all-genls (collection &key (kb *kb*))
  (when (collection? collection)
    (let ((entry (genls-cache-entry collection kb)))
      (when (and entry (listp (allgenls entry)))
        (mapcar 'predicate (allgenls entry))))))

(defun immediate-subsets (collection &key (kb *kb*))
  (when (collection? collection)
    (retrieve-subs collection (genls-cache kb))))

(defun all-subsets (collection &key (kb *kb*))
  (when (collection? collection)
    (let ((entry (genls-cache-entry collection kb)))
      (when entry
        (let ((result (compute-all-subsets entry)))
          (when (listp result)
            (mapcar 'predicate result)))))))

(defun instances-of (collection &key (kb *kb*))
  (when (collection? collection)
    (let ((sub-collections (all-subsets collection :kb kb))
          (result (mapcar 'cadr 
                    (retrieve `(data::isa ?x ,collection)))))
      (dolist (col sub-collections result)
        (dolist (isa (retrieve `(data::isa ?x ,col)))
          (pushnew (cadr isa) result :test 'equal))))))

(defun instances-of-collections (input-collections &key (kb *kb*))
  (do ((collections (remove-if-not 'collection? input-collections)
                    (nconc (cdr collections) new-collections))
       (instances nil)
       (collections-seen nil)
       (collection nil)
       (new-collections nil nil))
      ((null collections) instances)
    (setq collection (car collections))
    (unless (member collection collections-seen :test 'equal)
      (push collection collections-seen)
      (dolist (local-instance (retrieve `(data::isa ?x ,collection)
                                        :kb kb :response '?x))
        (pushnew local-instance instances :test 'equal))
      (setq new-collections (all-subsets collection :kb kb)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Genlpreds operations

(defun genlPreds (reln)
  (retrieve (make-genl-preds reln '?genl)
            :coverage :ground :response '?genl))

(defun all-genlPreds (reln)
  (do ((queue (genlPreds reln)
              (nconc new (cdr queue)))
       (result nil)
       (new nil nil))
      ((null queue) result)
    (unless (member (car queue) result
                    :test 'equal)
      (push (car queue) result)
      (dolist (super (genlPreds (car queue)))
        (unless (member super result
                        :test 'equal)
          (push super new))))))



(defun specPred-of? (pred super-pred)
  ;; Returns true if pred is a specPred of super-pred via
  ;;  some chain of genlPreds
  (member super-pred (all-genlPreds pred)))

(defun specPreds (reln)
  (retrieve (make-genl-preds '?spec reln)
            :coverage :ground :response '?spec))

;;; Added 7/16/03 (TRH)
(defun all-specPreds (pred)
  (let ((query (make-genl-preds '?specs pred)))
    (do* ((result (list pred))
          (queue result (cdr queue))
          (super (first queue) (first queue))
          (subs nil nil))
         ((null queue) result)
      (setf (third query) super)  ;; amortize the conses
      (setf subs (retrieve query :coverage :ground :response '?specs))
      (setf subs (delete-if #'(lambda (p) (member p result :test #'equal)) subs))
      (setf result (nconc result subs)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Arity and argument types

(defun arity (predicate &key (kb *kb*))
  (cond ((n-ary? predicate :kb kb) :n-ary)
        ((get-normal-arity-from-kb predicate kb))
        (t :unknown)))

(defun get-normal-arity-from-kb (pred kb)
  ;; normal means not n-ary in this function
  (let ((arity-form (retrieve (make-arity pred '?arity)
                              :kb kb :number 1
                              :coverage :ground)))
    ;; Assumes that arity form is unique
    (when (and arity-form (listp (car arity-form))
               (numberp (third (car arity-form))))
      (third (car arity-form)))))

(defun n-ary? (predicate &key (kb *kb*))
  (unless (variable? predicate)
    ;; N.B. Unknown => false here.
    (if (or (instance-of? predicate 
                          (if (mixed-case? kb)
                            'data::VariableArityRelation
                            'data::variable-arity-relation)
                          :kb kb)
            (instance-of? predicate
                          (if (mixed-case? kb)
                            'data::VariableArityFunction
                            'data::variable-arity-function)
                          :kb kb))
      t nil)))

(defun n-ary-expression? (expression &key (kb *kb*))
  (and (listp expression)
       (n-ary? (car expression) :kb kb)))

(defun arg-isa (predicate args &key (kb *kb*))
  (let ((arity (arity predicate :kb *kb*)))
    (cond ((eq arity :n-ary)
           (let ((type-form (retrieve (make-args-isa predicate 
                                                     '?type)
                                      :kb *kb* :number 1
                                      :coverage :ground)))
             (cond ((and type-form (listp type-form)
                         (listp (car type-form)))
                    (third (car type-form)))
                   (t :unknown))))
          ((integerp arity)
           (cond ((integerp args)
                  (cond ((or (> args arity) (< args 1))
                         (error
                             "Out of range argument for arg-isa: ~A out of ~A in ~A"
                           args arity predicate))
                        (t (retrieve-argn-isa predicate args kb))))
                 ((eq args :all)
                  (let ((result nil))
                    (dotimes (arg arity (nreverse result))
                      (push (retrieve-argn-isa predicate (1+ arg) kb)
                            result))))
                 (t (error "Unknown arg request: ~A for ~A in ARG-ISA."
                      args predicate))))
          (t (error "Unknown arity type: ~A in ~A."
               arity predicate)))))
                 
(defun retrieve-argn-isa (predicate n kb)                 
  (let ((type-form (retrieve 
                    (make-arg-type predicate '?type n)
                    :kb kb :number 1
                    :coverage :ground)))
    (cond ((and type-form (listp type-form)
                (listp (car type-form)))
           (third (car type-form)))
          (t :unknown))))
                 
(defun function? (pred)
  (unless (variable? pred)
    (or (instance-of-any? pred
                          (list 
 ;;;                            (if (mixed-case?) 'data::FunctionalPredicate
;;;                                  'data::functional-predicate)
                                (if (mixed-case?) 'data::Function-Denotational
                                  'data::function-denotational)
                                (if (mixed-case?) 'data::MeasurableAttributeType
                                  'data::measurable-attribute-type)))
        (fn-name-heuristic? pred))))

(defun produces-evaluatable-function? (pred)
  (and (function? pred)
       (eq (result-isa-type pred) (if (mixed-case?)
                                    'data::EvaluatableFunction 'data::evaluatable-function))))
(defun result-isa-type (pred)
  ;; Assumes it is a function, and only one resultIsa assertion holds
  (car (ask `(,(if (mixed-case?)
                 'data::resultIsa 'data::result-isa)
                ,pred ?type) *reasoner* :any 1 '?type :lookup-only)))
    
(defun evaluatable-function? (pred)
  (unless (variable? pred)

    (instance-of? pred (if (mixed-case?)
                         'data::EvaluatableFunction 'data::evaluatable-function))))

(defun evaluatable-relation? (pred)
  (unless (variable? pred)
    (instance-of? pred (if (mixed-case?)
                         'data::EvaluatableRelation 'data::evaluatable-relation))))

(defun nart-predicate? (pred)
  (unless (variable? pred)
    (instance-of? pred (if (mixed-case?)
                        'data::ReifiableFunction 'data::reifiable-function))))

;; Praveen was right re need to keep this fast for the canonicalizer -- KDF

(defun logical-connective? (symbol)
  (or (eq symbol 'data::implies)
      (eq symbol 'data::and)
      (eq symbol 'data::or)
      (eq symbol 'data::not)
      (eq symbol 'data::thereExists)
      (eq symbol 'data::forAll)
      (eq symbol 'data::equiv)
      (eq symbol 'data::xor)
      (eq symbol 'data::taxonomy)))

;;;(defun logical-connective? (pred)
;;;  (instance-of? pred (if (mixed-case?) 'data::LogicalConnective
;;;                       'data::logical-connective)))


(defun relation? (pred)
  (unless (variable? pred)
    (or (instance-of-any? pred 
                      (if (mixed-case?)
                        '(data::Relation data::Relationship data::Predicate data::RuleMacroPredicate)
                        '(data::relation data::relationship data::predicate data::rule-macro-predicate)))
        ;; These are higher order relationships, and the FIRE KB doesnt know that
        ;; This isnt the most elegant fix for that, but for the time being. 
        (if (mixed-case?) 
          (member pred '(data::relationAllInstance data::relationAllExists data::relationExistsAll
                                                   data::relationInstanceExistsMany data::relationInstanceAll 
                                                   data::relationInstanceExists data::relationAllExistsMany 
                                                   data::relationExistsInstance data::relationExistsExists))
          (member pred '(data::relation-all-instance data::relation-all-exists data::relation-exists-all
                                                   data::relation-instance-existsMany data::relation-instance-all 
                                                   data::relation-instance-exists data::relation-all-exists-many 
                                                   data::relation-exists-instance data::relation-exists-exists))))))

(defun commutative-relation? (pred)
  (unless (variable? pred)
    (instance-of? pred (if (mixed-case?)
                         'data::CommutativeRelation 'data::commutative-relation))))


(defun role-relation? (pred)
  (unless (variable? pred)
    (instance-of? pred (if (mixed-case?) 
                         'data::Role 'data::role-relation))))

;; Need a better test for :attribute. Use has-attributes? 

(defun predicate-type (pred &optional (kb *kb*))
  (let ((cached (gethash pred (predicate-type-cache kb))))
    (cond ((null cached)
           (setq cached (predicate-type-doit pred kb))
           (setf (gethash pred (predicate-type-cache kb))
             (if cached cached :NIL))
           cached)
          ((eq cached :NIL) nil)
          (t cached))))

(defun predicate-type-doit (pred kb)  ;; Returns one of :relation, :attribute :function :logical
  ;; These are based on the SME predicate types
  (with-kb kb
    (cond ((variable? pred) nil)
          ;; N.B. Never should get a variable in here, and if one does,
          ;; will retrieval all isas...
          ;; Order here is important: All functions are relations,
          ;; but not all relations are functions.
          ;; All functions are collections, but not vice versa
          ((function? pred) :function)
          ((collection? pred) :attribute)
          ((eq (arity pred) :unknown) nil)
          ((logical-connective? pred) :logical)
          ((relation? pred) :relation)
          (t :attribute))))



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



(defun non-atomic-term? (thing)
  (and (listp thing)
       (function? (car thing))))

(defun kappa-form? (thing)
  (and (listp thing)
       (if-mixed-case (eq (car thing) 'Kappa)
                      (eq (car thing) 'kappa))))

(defun lambda-form? (thing)
  (and (listp thing)
       (if-mixed-case (eq (car thing) 'Lambda)
                      (eq (car thing) 'lambda))))

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

(defun list-all-predicates (&key (kb *kb*))
  (let ((relations nil)
        (functions nil)
        (logical nil)
        (other nil))
    (dolist (pred (instances-of-collections 
                   (if (mixed-case?)
                     '(data::Relation data::Relationship data::Predicate data::RuleMacroPredicate)
                     '(data::relation data::relationship data::predicate data::rule-macro-predicate))
                   :kb kb)
                  (values relations functions logical other))
      (case (predicate-type pred kb)
        (:relation (push pred relations))
        (:function (push pred functions))
        (:logical (push pred logical))
        (t (push pred other))))))

(defun predicate-statistics (&key (kb *kb*) (stream *standard-output*))
  (declare (special data::*relations* data::*functions* 
                    data::*connectives* data::*other-predicates*))
  (multiple-value-setq (data::*relations* data::*functions* 
                                          data::*connectives*
                                          data::*other-predicates*)
    (list-all-predicates :kb kb))
  (format stream "~%For KB ~A, ~D functions, ~D relations, ~D connectives, ~D others."
    (name kb) (length data::*functions*)
    (length data::*relations*)
    (length data::*connectives*)
    (length data::*other-predicates*)))
           

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

      
    
                                    
                              
        



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
    

;;;; ---------------------------------------------------------------------------
;;; END OF CODE