;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: case-library.lsp
;;;;    System: FIRE
;;;;   Version: 1.0
;;;;    Author: Ken Forbus
;;;;   Created: December 31, 2000 15:20:17
;;;;   Purpose: Case library utilities
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Tuesday, February 24, 2004 at 11:12:29 by hinrichs
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;; These utilities are for handling explicit libraries of cases.
;;; The set of historical precedents from a region, the examples from
;;; a chapter, the stories one has heard about a particular phenomena
;;; are all examples of collections of descriptions that could be usefully
;;; treated as case libraries.  
;;; 
;;; Epistemlogically, case libraries are simply sets of descriptions.  
;;; Computationally, they have the additional property that one can,
;;; given a probe, ask to be reminded of the most similar case to
;;; that probe.  This is done using the MAC/FAC algorithm.
;;; 
;;; The simplest way of stipulating what is in a case library is to
;;; simply list its elements.  But, being a set, one can dynamically
;;; specify them as well.  The mechanisms provided here assume a particular
;;; construal of that set (as per BPS), and organize the MAC/FAC operations
;;; around them.

;;; Case library caches reside in two places.  
;;; 1. A case library can reside within a specific reasoner. Dynamically constructed
;;;    case libraries will typically be handled this way, since they are constructed to
;;;    tackle specific problems and are not a priori likely to be widely useful.
;;; 2. A case library can be cached within the KB.  This is more rare, and is intended
;;;    for case libraries that are heavily used by an application.  Because the KB doesn't
;;;    define task-specific ubiquitous predicates, we copy and normalize content vectors
;;;    into a library in the reasoner whenever it is going to be used.  We don't cache
;;;    dgroups in KB case libraries because they could get quite large.
;;; 3. A case library cached within a KB can be written out to disk, to provide persistent
;;;    storage.  Only the content vectors are saved, since the cost of recomputing them
;;;    is high -- each case must be constructed in order to build a content vector.
;;;   

(defclass case-library ()
  ((term :type t :initform nil :initarg :term :reader term
         :documentation "Expression denoting this case library")
   (parent :type t :initarg :parent :reader parent
           :documentation "Analogy source or KB this case library cache belongs to.")
   (members :type t :initform nil :initarg :members :accessor members
            :documentation "The set of cases currently known to be in this library.")
   (cvectors :type t :initform nil :initarg :cvectors :accessor cvectors
             :documentation "Alist of content vectors for the cases")
   (file-name :type t :initform "" :initarg :file-name :accessor file-name
              :documentation "Name of file, for caches stored to disk.")))

(defmethod print-object ((thing case-library) stream)
  (format stream "<CL: ~A:~A>" (term thing) 
    (let ((parent (parent thing)))
      (if (kb? parent) (name parent)
        (if (analogy-source? parent)
          (title (reasoner parent))
          parent)))))

(defmethod case-library? ((thing t)) nil)
(defmethod case-library? ((thing case-library)) t)

(defmethod clear-case-library-cache ((source analogy-source))
  (setf (case-libraries source) nil))

(defmethod clear-case-library-cache ((reasoner reasoner))
  (clear-case-library-cache (analogy-source-of reasoner)))

(defmethod clear-case-library-cache ((kb knowledge-base))
  (setf (case-libraries kb) nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creating case libraries

(defun retrieve-case-library (library-term parent)
  (cdr (assoc library-term (case-libraries parent)
              :test 'equal)))

(defmethod get-case-library ((library-term t) (parent knowledge-base))
  ;; Creates it if necessary
  (let ((library (retrieve-case-library library-term parent)))
    (if (case-library? library) library
      (if (case-library-cached-in-file? library-term parent)
        (let ((loaded (load-case-library-file library-term parent)))
          (if (case-library? loaded) loaded
            (cache-case-library library-term parent)))
        (cache-case-library library-term parent)))))

(defmethod get-case-library ((library-term t) (parent analogy-source))
  (let ((library (retrieve-case-library library-term parent)))
    (if (case-library? library) library
      (let ((kb-library (retrieve-case-library library-term (kb parent))))
        (if (case-library? kb-library)
          (copy-kb-case-library-into-source kb-library parent)
          (cache-case-library library-term parent))))))

(defun copy-kb-case-library-into-source (kb-library parent)
  ;; Parent = analogy source
  (let ((source-library (make-instance 'case-library :term (copy-tree (term kb-library))
                          :parent parent
                          :members (members kb-library)
                          :cvectors (mapcar #'(lambda (cv)
                                                (let ((new-cv (copy-cv cv)))
                                                  (normalize-cv new-cv parent)))
                                      (cvectors kb-library)))))
    (push (cons (term source-library) source-library) (case-libraries parent))
    source-library))
;; ****** Should we do the case library contents term?  Think about this.
    
(defmethod cache-case-library ((library-term t) (parent analogy-source))
  (with-kb (kb parent) (do-case-library-cache library-term parent)))

(defmethod cache-case-library ((library-term t) (parent knowledge-base))
  (with-kb parent (do-case-library-cache library-term parent)))

(defun do-case-library-cache (library-term parent)
  ;; Requires a reasoner with an analogy source, even if the parent is a KB
  ;; Otherwise ASK doesn't work properly, and it is used by some of the reasoning
  ;; used in gathering case library entries
  (let* ((library (make-instance 'case-library :term library-term
                    :parent parent))
         (members (gather-case-library-contents (car library-term)
                                                (cdr library-term)
                                                (if (kb? parent)
                                                  (analogy-source-of *reasoner*)
                                                  parent))))
    (push (cons library-term library) (case-libraries parent))
    (setf (members library) members)
;;;    (retract-previous-case-library-contents-assertions library-term)
;;;    (tell (make-case-library-contents library-term (make-set members))
;;;          reasoner :mac/fac :all)
    ;; **** CS 344 Homework: Implement CWA update mechanism for tracking contents
    ;; We used to construct the cvectors by default.  Don't really want to do that, because
    ;; we might decide not to use that case library, in which case the effort to regenerate it
    ;; is kind of wasted.
    library))
    
(defun retract-previous-case-library-contents-assertions (library-term)
  (dolist (previous (ltre:fetch-trues (make-case-library-contents library-term '?members)))
    (ltre::retract! previous (ltre:informant-of previous))))

(defun get-case-library-cvectors (library)
  (cond ((cvectors library) ;; Assume cache is accurate
         (cvectors library))
        (t (update-case-library-content-vectors library)
           (cvectors library))))

(defun update-case-library-content-vectors (library)
  (let* ((parent (parent library))
         (kb (if (kb? parent) parent
               (if (analogy-source? parent)
                 (kb parent)
                 (error "Free-floating case library? ~A." library))))
         (source (if (analogy-source? parent) parent
                   (if (kb? parent)
                     (let ((reasoner *reasoner*))
                       (if (reasoner? reasoner)
                         (let ((the-source (analogy-source-of reasoner)))
                           (if (analogy-source? the-source) the-source
                             (error "Current reasoner has no analogy source: ~A, ~A."
                               library reasoner)))
                         (error "No current reasoner: ~A" library)))
                     (error "Free-floating case library? ~A." library))))
         
         (normalize? (analogy-source? parent)))
    (with-kb kb
      (dolist (case-term (members library) library)
        ;; ****** This should be more clever, by exploiting cached dgroups when they are
        ;; ******   available.  That could save a lot of time with overlapping dgroups.
        (let* ((facts (gather-dgroup-facts (car case-term) (cdr case-term) source))
               (cv (make-cv-from-facts case-term facts)))
          (if normalize? (normalize-cv cv source))
          (push cv (cvectors library)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; gather-case-library-contents
;;; This method gathers up the cases that should be used as part of a case library.
;;; The intent is to support dynamic selection, e.g.
;;; (casesSatisfyingFn ?case (and (caseIncludes ?case SpatialLocation FreedoniaRegion)
;;;                               (caseIncludes ?case MaleficiaryOf Firefly)))
;;;
;;;
;;; For modularity, these just gather the contents, the libraries are constructed
;;; and maintained independently of how the gathering occurred above.


;; (CaseLibraryFn <term list) refers to an explicitly stored set of cases.
;;
;; As with explicit-case-fn, we simply use the term for these simple case libraries.

(defmethod gather-case-library-contents ((type (eql 'data::case-library-fn))
                                         (specs list)
                                         (source analogy-source))
  (ask (make-element-statement 'data::?case (cons type specs))
       (reasoner source)
       :any :all
       'data::?case
       :all))

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibraryFn))
                                         (specs list)
                                         (source analogy-source))
  (ask (make-element-statement 'data::?case (cons type specs))
       (reasoner source)
       :any :all
       'data::?case
       :all))

;; (CaseLibrarySansFn <CL NAT> <case>)
;; where <CL NAT> = a NAT referring to a case library and <case> is a case,
;; denotes the case library consisting of <CL NAT> - <case>

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibrarySansFn))
                                         (specs list)
                                         (source analogy-source))
  (gather-case-library-contents 'data::case-library-sans-fn
                                specs source))

(defmethod gather-case-library-contents ((type (eql 'data::case-library-sans-fn))
                                     (specs list)
                                     (source analogy-source))
  (unless (= (length specs) 2)
    (warn "Case Library Sans Fn received incorrect arguments: ~A, ~A."
      type specs)
    (return-from gather-case-library-contents (values nil)))
  (let ((starting-point (get-case-library (car specs) source)))
    (cond ((not (case-library? starting-point))
           (warn "Case Library NAT to CaseLibrarySans failed: ~A, ~A."
             type specs) 
           nil)
          (t (remove (cadr specs) (members starting-point) :test 'equal)))))

;; (CaseLibraryMinusFn <CL NAT> <case list>)
;; where <CL NAT> = a NAT denoting a case library
;; and <case list> = list of cases (syntactically, (TheList . cases)
;; denotes the case library consisting of <CL NAT> - <case list>

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibraryMinusFn))
                                         (specs list)
                                         (source analogy-source))
  (gather-case-library-contents 'data::case-library-minus-fn
                                specs source))

(defmethod gather-case-library-contents ((type (eql 'data::case-library-minus-fn))
                                         (specs list)
                                         (source analogy-source))
  (unless (and (= (length specs) 2)
               (listp (cadr specs))
               (eq (car (cadr specs))
                   (if-mixed-case 'data::TheList 'data::the-list)))
    (warn "Ill-formed Case Library Minus term: ~A, ~A" type specs)
    (return-from gather-case-library-contents (values nil)))
  (let ((starting-point (get-case-library (car specs) source)))
    (cond ((not (case-library? starting-point))
           (warn "Case Library NAT to CaseLibraryMinus failed: ~A, ~A."
             type specs)
           nil)
          (t (set-difference (members starting-point)
                             (cdar specs) :test 'equal)))))
           

;; (CaseLibraryInstancesOfFn <collection> <dgroup fn>) denotes the case library consisting
;; of all things that are instances of <collection> using the case constructor <dgroup fn>

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibraryInstancesOfFn))
                                     (specs list)
                                     (source analogy-source))
  (gather-case-library-contents 'data::case-library-instances-of-fn
                                specs source))

(defmethod gather-case-library-contents ((type (eql 'data::case-library-instances-of-fn))
                                     (specs list)
                                     (source analogy-source))
  (when (collection? (car specs))
    (mapcar #'(lambda (entity) (list (cadr specs) entity))
      (instances-of (car specs)))))

;; (CaseLibrarySubcollectionsOfFn <collection> <dgroup fn>) denotes the case library
;; consisting of all things that are subcollections of <collection>, using the case
;; constructor <dgroup fn>

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibrarySubcollectionsOfFn))
                                         (specs list)
                                         (source analogy-source))
  (when (and (collection? (car specs))
             (cadr specs))
    ;;***** If we had a good way to test for whether or not something was a dynamic
    ;;***** case constructor, it would be a nicer test to use than the cadr above.
    (do-gather-subcollections-of (car specs) (cadr specs) source)))

(defmethod gather-case-library-contents ((type (eql 'data::case-library-subcollections-of-fn))
                                         (specs list)
                                         (source analogy-source))
  (when (and (collection? (car specs))
             (cadr specs))
    ;;***** If we had a good way to test for whether or not something was a dynamic
    ;;***** case constructor, it would be a nicer test to use than the cadr above.
    (do-gather-subcollections-of (car specs) (cadr specs) source)))

(defun do-gather-subcollections-of (collection case-constructor source)
  (mapcar #'(lambda (subcol) (list case-constructor subcol))
    (all-specs collection :kb (kb (reasoner source)))))

;; (CaseLibrarySatisfyingFn <var> <statement> <dgroup fn>) denotes the case library
;; consisting of all legal bindings of <var> which satisfy <statement>, using the
;; case constructor <dgroup fn>.

(defmethod gather-case-library-contents ((type (eql 'data::CaseLibrarySatisfyingFn))
                                         (specs list)
                                         (source analogy-source))
  (when (and (variable? (car specs))
             (not (ltre::free-in? (car specs) (cadr specs) nil)) ;; Must mention var
             (third specs)) ;; Might be nice to have a better test here
    (do-gather-satisfying-case-library (car specs) (cadr specs) (third specs) source)))

(defmethod gather-case-library-contents ((type (eql 'data::case-library-satisfying-fn))
                                         (specs list)
                                         (source analogy-source))
  (when (and (variable? (car specs))
             (not (ltre::free-in? (car specs) (cadr specs) nil)) ;; Must mention var
             (third specs)) ;; Might be nice to have a better test here
    (do-gather-satisfying-case-library (car specs) (cadr specs) (third specs) source)))

(defun do-gather-satisfying-case-library (var statement case-constructor source)
  
  (mapcar #'(lambda (thing) (list case-constructor thing))
    (fire::ask-it statement :response var
                  :reasoner (reasoner source))))







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