;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: dynamic-case-construction.lsp
;;;;    System: 
;;;;    Author: Shawn Nicholson
;;;;   Created: February 24, 2002 15:08:34
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, November 16, 2003 at 20:33:40 by sathya
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;
;;; The dynamic case construction methods as referenced in 
;;;  Mostek, T, Forbus, K, Meverden, C. (2000) Dynamic case creation and expansion
;;;      for analogical reasoning.   Proceedings of AAAI 2000.

(defparameter *bad-cyc-predicates* 
  ;; Predicates mentioned in the KB, which are not defined in the KB
  (list 'data::CityInCountryFn
        'data::Promotion-AdvocacyFn
        'data::Percent
        'data::LongitudeLineFn
        'data::LatitudeLineFn
        'data::Meter
        'data::Foot-UnitOfMeasure
        'data::permanentlyNorthOf
        'data::SquareMile
        'data::countryOfCity
        'data::sponsors
        'data::MapFn-Individual
        'data::agreeingAgents
        'data::specifiedSubsetOf
        'data::CollectionQualificationFn
        'data::signatories
        'data::permanentlyEastOf
        'data::permanentlyNortheastOf
        'data::accused
        'data::ArbitraryInstanceFn
        'data::permanentlyNorthwestOf
        'data::Rial-Iran
        'data::SomeExampleFn
        'data::regionControlled
        'data::Kappa              ;;; This IS defined - but kappa exp's don't work atm
        'data::YearsDuration
        'data::Mile
        'data::MillionBarrelsPerDay
        'data::Dollar-UnitedStates
        'data::conflictingInterestsWRT
        'data::coincidingInterestsWRT
        'data::KiloWattHour
        'data::ShortTon
        'data::CubicFoot
        'data::BarrelsPerDay
        'data::borderOf
        'data::dateOfEvent
        'data::ICCES-COAPredicate
        'data::keClarifyingCollection
        'data::productionCapacity
        ))

(defparameter *special-filter-predicates*
  (list 'data::inDomainTheory  ;; FIRE does not handle domain theories yet so this isn't defined
        'data::prettyName      ;; genFormat strings are not predicates
        ))

(defun fact-predicate (fact)
  (car fact))

(defun relevant-predicate? (pred)
  ;; By default, assume everything is relevant
  (declare (ignore pred))
  t)
  
(defparameter *special-bookkeeping-predicates*
  (list 'data::synonymousExternalConcept))

(defun book-keeping-fact? (fact)
  (let ((pred (fact-predicate fact)))
    (or (member pred *special-bookkeeping-predicates*)
        (instance-of-any? pred (if (mixed-case?)
                                 (list 'data::BookkeepingPredicate
                                       'data::DocumentationConstant
                                       'data::MetaKnowledgePredicate)
                                 (list 'data::bookkeeping-predicate
                                       'data::documentation-constant
                                       'data::meta-knowledge-predicate))))))


(defgeneric filter-fact? (fact source filter-style)
  (:documentation "Returns true if fact is to be ignored/filtered. Specialized on 
     the filter-style which can be one of MinimalCaseFun at the moment"))

;; When dynamically creating a case for concept X, we don't want to get
;;  expressions where X is a predicate being applied to something
;; Example: genls - we don't want every (genls a b) to show up since 
;;  these are not really expressions about the concept genls

(defun relevant-mentioning-expr? (concept fact)
  ;; Returns true if 
  ;;  1) concept is NOT the predicate in fact
  ;;  2) concept is the predicate, AND is mentioned elsewhere in fact
  ;; returns false otherwise
  (or (not (equal concept (fact-predicate fact)))
      (member concept (rest fact))))


(defun get-basic-relevant-facts (concept mentioning-facts source filter-type)
  (let ((basic-relevant-facts nil))
    (dolist (fact mentioning-facts basic-relevant-facts)
      (when (and (relevant-mentioning-expr? concept fact)
                 (relevant-predicate? (fact-predicate fact))
                 (not (filter-fact? fact source filter-type)))
        (push fact basic-relevant-facts)))))

(defun contains-bad-cyc-predicate? (fact)
  ;; Returns true if fact contains one of the bad cyc predicates
  ;;  in a predicate position (ie it's the car of any sublist in fact)
  (and (listp fact)
       (or (variable? (first fact))
           (member (first fact) *bad-cyc-predicates*)
           (find-if 'contains-bad-cyc-predicate? (rest fact)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gathering entities from expressions
;; N.B. This procedure and its helpers assume that statements
;; are in FIRE form, i.e., with ISA statements.  The procedure
;; extract-entities-and-expressions, in dgroup.lsp, assumes
;; that they are in SME form, i.e., in attribute form.  
;; These are not interchangable!

(defun gather-entities-from-expressions (facts source)
  (do ((exprs (cdr facts) (cdr exprs))
       (fact (car facts) (car exprs))
       (entities nil))
      ((and (null fact) (null exprs)) entities)
    (unless (not-for-analogy-exp? fact source)
      ;; We don't want to even touch NotForAnalogyPredicate facts, since
      ;; they might mention entities (like comments and name strings!)
      ;; that don't play any role in any other expression, and hence
      ;; shouldn't be used in analogies
      (cond ((should-be-atomic-NAT? fact) 
             (pushnew fact entities :test 'equal))
            (t (dolist (entity (gather-entities-from-expression fact))
                 (pushnew entity entities :test 'equal)))))))

(defun gather-entities-from-expression (fact)
  (cond ((null fact) nil)
        ((not (listp fact)) nil)
        ((should-be-atomic-NAT? fact) (list fact))
        ((isa-statement? fact) ;; Ignore the collection, it's an attribute not an entity
         (gather-entities-from-argument (cadr fact)))
        (t ;; We ignore the predicate, since we aren't decomposing NATs when used as predicates
         ;; We go over the arguments and figure out what to do with them.
         (mapcan #'gather-entities-from-argument (cdr fact)))))

(defun gather-entities-from-argument (arg)
  (cond ((null arg) (list nil))
        ((not (listp arg)) (list arg))
        ((should-be-atomic-NAT? arg) (list arg))
        ((isa-statement? arg)
         (gather-entities-from-argument (cadr arg)))
        (t ;; Must be an expression.  So we recurse
         (gather-entities-from-expression arg))))
             
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Minimal Case Function
;;;  Extracts all references to a seed S with the following filters 
;;;    Bookkeeping-expression?
;;;    

(defmethod filter-fact? (fact source (filter-style (eql :MinimalCaseFn)))
  ;; For minimal case fun, you simply take every expression except
  ;;  for the ones with bookkeeping predicates
  (declare (ignore source))
  (or (contains-bad-cyc-predicate? fact)
      (member (fact-predicate fact) *special-filter-predicates*)
      (book-keeping-fact? fact)))

(defmethod filter-fact? (fact source (filter-style (eql :minimal-case-fn)))
  (filter-fact? fact source :MinimalCaseFn))

(defmethod gather-dgroup-facts ((type (eql 'data::MinimalCaseFn))
                                (args list)
                                (source analogy-source))
  (let* ((reasoner (reasoner source))
         (concept (car args))
         (case-term (make-minimal-case-fn concept))
         (facts (gather-minimal-case-dgroup-facts concept source)))
    (dolist (fact facts facts) ;; Reify in working memory for justifications
      (tell-it (make-case-fact case-term fact) :reasoner reasoner))))

;; ****** Maybe we shouldn't reify cases in the working memory except on demand?
;; ****** That would really cut down the LTRE load.

(defmethod gather-dgroup-facts ((type (eql 'data::minimal-case-fn))
                                (args list)
                                (source analogy-source))
  (gather-dgroup-facts 'data::MinimalCaseFn args source))

(defun gather-minimal-case-dgroup-facts (concept source)
  (get-basic-relevant-facts concept (retrieve-references concept)
                            source :MinimalCaseFn))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Case Fn
;; This augments minimal case fn by including isa facts (i.e., attributes)
;; for all entities in the description.  This provides a bit more grist for
;; finding reasonable matches between participants in an event, for example.
;; This was the default case constructor in our first crisis management system.

;; N.B. The use of the result of extract-entities-and-expressions below depends on
;; the assumption that what is an internal predicate (i.e., not for analogy) doesn't
;; change over a reasoning session.  Except for times when one is doing low-level 
;; debugging/performance tuning, this seems to be a reasonable assumption.

(defmethod filter-fact? (fact source (filter-style (eql :CaseFn)))
  (declare (ignore source))
  (or (contains-bad-cyc-predicate? fact)
      (member (fact-predicate fact) *special-filter-predicates*)
      (book-keeping-fact? fact)))

(defmethod filter-fact? (fact source (filter-style (eql :case-fn)))
  (filter-fact? fact source :CaseFn))

(defmethod gather-dgroup-facts ((type (eql 'data::CaseFn))
                                (args list)
                                (source analogy-source))
  (let* ((reasoner (reasoner source))
         (concept (car args))
         (case-term (encase-case concept :case-fn))
         (facts (gather-case-fn-facts concept source)))
    (dolist (fact facts facts)
      (tell-it (make-case-fact case-term fact)
               :reasoner reasoner))))

(defmethod gather-dgroup-facts ((type (eql 'data::case-fn))
                                (args list) (source analogy-source))
  (gather-dgroup-facts 'data::CaseFn args source))

(defun gather-case-fn-facts (concept source)
  (let* ((mentioning-facts (retrieve-references concept))
         (facts (get-basic-relevant-facts concept mentioning-facts source :CaseFn))
         (entities (gather-entities-from-expressions facts source)))
    ;; augment the expressions with the attribute information for entities
    (dolist (entity entities)
      (unless (equal entity concept)
        (dolist (attribute (retrieve-isas entity))
          (push (make-isa entity attribute) facts))))
      facts))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; EVENT-CASE-FN
;; This is the same as case-fn plus we find all the sub-events that were gathered
;; and find all their references in the list of given predicates

(defun gather-event-case-fn-facts (event source)
  (let* ((facts (get-basic-relevant-facts event (retrieve-references event)
                                          source :EventCaseFn))
         (entities (gather-entities-from-expressions facts source)))
    (dolist (entity entities)
      (unless (equal entity event)
        (dolist (attribute (retrieve-isas entity))
          (push (make-isa entity attribute) facts))))
    (nunion facts (gather-facts-of-predicates-involving entities
                                                        (relevant-predicates-for-case-type 
                                                         :EventCaseFn source)
                                                        (reasoner source)))))

(defmethod filter-fact? (fact source (filter-style (eql :EventCaseFn)))
  (filter-fact? fact source :MinimalCaseFn))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Defining relevant predicates, and retrieving facts involving them

(defmethod relevant-predicates-for-case-type ((case-type t)
                                              (source t)) 
  nil) ;; No data, then punt.

(defmethod relevent-predicates-for-case-type ((case-type (eql :EventCaseFn))
                                              (source analogy-source))
  ;; We need to work with the Cyc folks to do some reorganization of the KB
  ;; Right now, there isn't any overarching structure that would help us figure
  ;; this sort of thing out, and that's where it should be.  
  ;; (ask-it `(and (isa ?x CausalPredicate) (isa ?x BinaryPredicate))
  ;;          :response '?x)
  ;; should be enough to do the trick.  Sigh.
  ;; N.B. This list is very incomplete.
  '(data::causes-SitProp data::causes-EventEvent data::causes-ThingProp
                         data::causes-PropProp data::causes-EventEvent
                         data::causes-SitTypeSitType data::causes-SitTypeProp
                         data::causes-SitSitType data::causes-Generic
                         data::eventOutcomes data::postEvents data::postSituation
                         data::inReactionTo data::adversarialResponseTo))

;; ***** Define :event-case-fn with whatever hyphenated predicates

(defun gather-facts-of-predicates-involving (entities predicates reasoner)
  ;; Assuming binary predicates for now.  Need to have a more robust way
  ;; to handle things like this.
  ;; N.B. This will not find facts that are stated as holding within some
  ;; spatial context, nor will it find facts that are stashed away in
  ;; episodic memories.  This needs to be thought through.
  (let ((relevant-facts nil))
    (dolist (e entities relevant-facts)
      (dolist (predicate predicates)
        (dolist (fact (ask-it (list predicate e '?two) :reasoner reasoner))
          (pushnew fact relevant-facts :test 'equal))
        (dolist (fact (ask-it (list predicate '?one e) :reasoner reasoner))
          (pushnew fact relevant-facts :test 'equal))))))
          

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Thought experiment: Following the AAAI 2000 paper very closely
;;;;
;;;; Promising, but  not today.
;;;
;;;(defun generate-case (seed predicates case-type source depth)
;;;  ;; Nomenclature translation from GenerateCase in AAAI 2000 paper
;;;  ;; seed = s, what the case is about.
;;;  ;; Unlike the version in the AAAI 2000 paper, we split the filtering into
;;;  ;; two parts: The bookkeeping/internal removal, and filtering based on 
;;;  ;; specifics of the case type itself.  The latter is handled by the
;;;  ;; method filter-fact?.  The concept of relevant predicates is 
;;;  (let* ((reasoner (reasoner source))
;;;         (relevant-basic-facts (compute-relevant-basic-facts seed
;;;                                                             source case-type depth)))
;;;    (multiple-value-bind (entities expressions)
;;;        (extract-entities-and-expressions relevant-mentions source)
;;;      ;; entities = GT(RM(S,T))
;;;      (dolist (e entities)
;;;        (setq relevant-basic-facts 
;;;              (nconc relevant-basic-facts 
;;;                     (generate-case e predicates case-type source (1+ depth)))))
;;;      relevant-basic-facts)))
;;;
;;;(defmethod compute-relevant-basic-facts ((seed t)
;;;                                         (source analogy-source)
;;;                                         (case-type (eql :EventCaseFn))
;;;                                         (depth integer))
;;;  (cond ((> depth 1) nil)
;;;        ((= depth 0) ;; Get everything
;;;         )
;;;        (t ;; Get isa's
;;;         )))
;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Regression testing

(defparameter *all-entity-list* nil)
(defparameter *reported-errors* nil)
(defparameter *current-concept* nil)

;;; trap-qrg-conditions is not loaded in the linux image and causes this to barf:
#-unix
(defun complete-kb-dynamic-case-construction (&key (case-construction-style :MinimalCaseFn)
                                                   (force-reload nil))
  ;; Warning - this takes a LONG TIME.....
  ;; Want to make sure we can dynamically create cases for 
  ;;  every concept in the kb
  (let ((entities nil)
        (src (make-instance 'analogy-source 
               :reasoner (make-reasoner "Dynamic Case Construction Test Reasoner"))))
    
    (if (and (not force-reload) 
             *all-entity-list*)
      (setq entities *all-entity-list*)
      (setq entities (retrieve '(isa ?x ?y) :response '?x)))
    
    (setf *reported-errors* nil)
    
    
    (dolist (concept entities)
      (setq *current-concept* concept)
      (multiple-value-bind (ret err)
          (ignore-errors 
           (trap-qrg-conditions ((push condition *reported-errors*))
                                (fire::get-dgroup
                                 (encase-case concept case-construction-style) src)))
        (declare (ignore ret))
        (when err
          (push err *reported-errors*))))
   
    (if *reported-errors*
      *reported-errors*
      'Done-No-Errors)))

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