;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: dgroup.lsp
;;;;    System: FIRE analogy source
;;;;   Version: 1.0
;;;;    Author: Ken Forbus
;;;;   Created: December 28, 2000 12:23:11
;;;;   Purpose: Defining SME descriptions
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Wednesday, April 14, 2004 at 17:37:38 by forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;; SME dgroups are a construal of a case.  They use a specialized internal
;;;; representation that facilitates matching.
;;;; 
;;;; Creating dgroups from a large
;;;; knowledge base requires doing the following:
;;;; 1. Figuring out what set of facts should be in the construal.
;;;; 2. Extracting the entities from that set of facts.
;;;; The first job is carried out by the method gather-dgroup-facts, defined below.
;;;; The second job is carried out by extract-entities-and-expressions, defined below.

(defun get-dgroup (dgroup-term source &key (refresh nil))
  (let ((cached-entry (find dgroup-term (dgroups source)
                            :test 'equal
                            :key 'sme::name)))
    (cond ((and refresh cached-entry)
           (get-updated-dgroup cached-entry source))
          (cached-entry)
          (t (create-dgroup dgroup-term source)))))

;; For debugging
(defun clear-dgroup-cache (source) (setf (dgroups source) nil))

(defun uncache-dgroup (name source)
  (setf (dgroups source) (delete-if #'(lambda (x) (equal (sme::name x) name))
                                    (dgroups source))))

(defmethod create-dgroup ((dgroup-spec list) (source analogy-source))
  (make-dgroup-from-facts dgroup-spec
                          (gather-dgroup-facts (car dgroup-spec)
                                               (cdr dgroup-spec) source)
                          source))

;; Issue: How much caching should we do of dgroups?  
;; Facts can be added, so that even (explictCaseFn ..) can be
;; changing over time.  The most accurate solutions are to (a)
;; ban changes in dgroups once referred to or (b) use CWA's to track
;; changes.  Probably best to do the equivalent of time-stamping,
;; i.e., (extended-case-fn <case specifier> <new data>) would let us
;; refer to the set of facts associated with a case.  Still need to
;; be able to know that the facts retrieved are different, however.
;; Also, need to handle subtractive changes.
;; Current solution: Ignore this issue.  Need more data about how we're
;; going to use the system.

(defmethod make-dgroup-from-facts ((name t) (facts list) (source analogy-source))
  (multiple-value-bind (entities expressions)
      (extract-entities-and-expressions 
       (delete nil (mapcar 'fire->sme-expression facts)) source)
    (let ((dgroup (make-instance sme::*sme-description-default-class*
                    :name name
                    :id (get-new-dgroup-id source)
                    :vocabulary source)))
      (dolist (entity entities)
        (sme::define-entity entity dgroup))  
      (dolist (expression expressions)
          (sme::define-expression expression dgroup))
      (push dgroup (dgroups source))
      dgroup)))

(defun not-for-analogy-exp? (exp source)
  ;; This is only going to be called on assertions in SME form, 
  ;; i.e., isa, has-attribute, etc --> attributes, + anything else.
  ;; So we can simplify
  (cond ((listp exp)
         (let ((sc-entry (find-sc-entry (first exp) (kb source))))
           (cond ((null sc-entry) 
                  (cond ((listp (first exp)) 
                         ;; Is the result of this expression going to be
                         ;; something internal?
                         (not-for-analogy-exp? (car exp) source))
                        ;; N.B. Recursing here isn't quite right.  Ideally
                        ;; we'd look at the kind of predicate produced by
                        ;; the function (otherwise it's not legal) and 
                        ;; make a judgement based on that.  But this case
                        ;; seems to be extremely unlikely.
                        (t nil)))
          (t (member (sc-id sc-entry)
                     (internal-predicates source) :test '=)))))
        (t nil))) ;; Expression to SME are always lists

(defmethod sme::drawn-from-external-knowledge? ((description sme::description)) 
  ;; ***** Probably should subclass dgroups used in FIRE so that we don't
  ;; ***** apply this to any other uses of SME in the same Lisp environment.
  ;; ***** but that's pretty unlikely, so defer for later.
  (analogy-source? (sme::vocabulary description)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Extracting entities and expressions
;; There's an interesting issue w.r.t. NAT's.
;; Do we decompose them or not?
;; Previous code was inconsistent about this choice.  Not good.
;; This version tests an expression to see if it is a NAT that
;; should be treated as atomic (i.e., the test should-be-atomic-NAT?).
;; The tradeoff is that atomic NATs can insulate SME from irrelevant
;; representational choices (i.e., the way glyph NATs are implemented 
;; in nuSketch systems) and provide a quicker gloss over a representation.
;; The cost is that cross-dimensional mappings would then be hidden, i.e.,
;; terms like (pressure water) and (temperature coffee) would be treated as
;; entities, so that structural relationships between the entities would not
;; be found nor would the correspondence between the dimensions, which would
;; mean that it needn't be enforced consistently across the mapping.
;; In some sense, if rerepresentation is cheap one could always start NATs as
;; entities, and decompose later.  But that's still very much an empirical
;; question, so for efficiency right now this code is hard-wired to only 
;; produce NATs in the cases where we clearly know they are appropriate.

(defun extract-entities-and-expressions (facts source)
  (do ((exprs (cdr facts) (cdr exprs))
       (fact (car facts) (car exprs))
       (expressions nil)
       (entities nil))
      ((and (null fact) (null exprs)) (values entities expressions))
    (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 in the dgroup.
      (cond ((should-be-atomic-NAT? fact) 
             (pushnew fact entities :test 'equal))
            (t (dolist (entity (extract-entities-from-expression fact))
                 (pushnew entity entities :test 'equal))
               (push fact expressions))))))

(defun extract-entities-from-expression (fact)
  (cond ((null fact) nil)
        ((not (listp fact)) nil)
        ((should-be-atomic-NAT? fact) (list 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 #'find-entities-from-argument (cdr fact)))))

(defun find-entities-from-argument (arg)
  (cond ((null arg) (list nil))
        ((not (listp arg)) (list arg))
        ((should-be-atomic-NAT? arg) (list arg))
        (t ;; Must be an expression.  So we recurse
         (extract-entities-from-expression arg))))

(defun should-be-atomic-NAT? (thing)
  (and (listp thing)
       ;; Quick experiment
       (member (car thing)
               '(data::GlyphFn ;; KDF: Commented this out because it's hosing nSB
                               ;; Not clear that this is a win, however.
                               ;; data::TheList 
                               data::ContainedGlyphGroupFn data::GlyphConnectionGraphFn
                               data::ConnectedGlyphGroupFn data::GlyphContainedGraphFn))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
;;; gather-dgroup-facts carries out dynamic case construction.
;;; For each case function, define a method that handles it appropriately.
;;;
;;; N.B. The mixed-case/hyphen choice requires us to duplicate methods, since
;;; one cannot do an (or (eql ...) (eql ...)) in CLOS.  Such is life.

(defgeneric gather-dgroup-facts (type specs source)
  (:documentation "Returns list of facts from the KB that go into making the 
      case for the SPECS using filter-type TYPE"))

(defmethod gather-dgroup-facts ((type (eql 'data::explicit-case-fn))
                                (specs list)
                                (source analogy-source))
  (gather-explicit-case-dgroup (car specs) source))

(defmethod gather-dgroup-facts ((type (eql 'data::ExplicitCaseFn))
                                (specs list)
                                (source analogy-source))

  (gather-explicit-case-dgroup (car specs) source))

(defun gather-explicit-case-dgroup (case-name source)
  ;; (explicit-case-fn <case name>)
  ;; (explicitCaseFn <case name>)
  (ask (make-case-fact case-name '?fact)
       (reasoner source)
       :any ;; context
       :all ;; number
       '?fact ;; just the facts, ma'm
       :lookup))

;;; Slight subtlety: We want to be able to grab cases stored in WM,
;;; without touching the KB.  So we define a new function,
;;; WMCaseFn which takes a case as an argument, and refers to
;;; the version of that case stored in the WM.

;;;; ******* Add these to the flat files
;;;; (isa WMCaseFn Function-Denotational)
;;;; (resultIsa WMCaseFn Case)
;;;; (arg1Isa WMCaseFn Case)

(defmethod gather-dgroup-facts ((type (eql 'data::WMCaseFn))
                                (specs list)
                                (source analogy-source))
  (gather-wm-case-facts (car specs) (ltre (reasoner source))))

(defmethod gather-dgroup-facts ((type (eql 'data::wm-case-fn))
                                (specs list)
                                (source analogy-source))
  (gather-wm-case-facts (car specs) (ltre (reasoner source))))

(defun gather-wm-case-facts (case-id ltre)
  (mapcar 'third 
    (ltre:fetch-trues (make-case-fact case-id '?fact) ltre)))

(defmethod gather-dgroup-facts ((type (eql 'data::AskCaseFn))
                                (specs list)
                                (source analogy-source))
  (gather-case-dgroup-using-ask (car specs) source))

(defmethod gather-dgroup-facts ((type (eql 'data::ask-case-fn))
                                (specs list)
                                (source analogy-source))
  (gather-case-dgroup-using-ask (car specs) source))

(defun gather-case-dgroup-using-ask (query source)
  (cond ((or (eq (car query)
                 'data::TheSetOf)
             (eq (car query)
             'data::the-set-of))
         ;;(AskCaseFn
         ;;        (TheSetOf ?s
         ;;                (and (ist-Information Agent-SpecificFactsheet-IranMt ?s)
         ;;                     (termFormulas ?s Iraq))))
         ;;We could use eval source to evaluate '(TheSetOf ..)' but having the analogy source
         ;;be independent of the eval source for now.
         (ask (third query)
              (reasoner source)
              :any
              :all
              (second query)
              :lookup))
        (t (ask query
              (reasoner source)
              :any
              :all
              :pattern
                :lookup))))

;;; Sometimes we want to hone in on ground facts first, using them
;;; to establish correspondences that are used to constrain the match.
;;; (GroundCaseFn <case>) refers to the ground statements in <case>.

(defmethod gather-dgroup-facts ((type (eql 'data::GroundCaseFn))
                                (specs list)
                                (source analogy-source))
  (let ((reasoner (reasoner source))
        (case-term (cons type specs))
        (facts (gather-ground-case-facts (car specs) source)))
    (dolist (fact facts)
      ;; Reify in working memory for justifications
      ;; *** Maybe we shouldn't reify cases in the working memory 
      ;; *** except on demand?  That would really cut down the LTRE load.
      (tell-it (make-case-fact case-term fact) :reasoner reasoner))
    facts))

(defmethod gather-dgroup-facts ((type (eql 'data::ground-case-fn))
                                (specs list)
                                (source analogy-source))
  (let ((reasoner (reasoner source))
        (case-term (cons type specs))
        (facts (gather-ground-case-facts (car specs) source)))
    (dolist (fact facts)
      ;; Reify in working memory for justifications
      ;; *** Maybe we shouldn't reify cases in the working memory 
      ;; *** except on demand?  That would really cut down the LTRE load.
      (tell-it (make-case-fact case-term fact) :reasoner reasoner))
    facts))



(defun gather-ground-case-facts (case-specification source)
  (remove-if-not 'ground-formula? 
                 (gather-dgroup-facts (car case-specification)
                                      (cdr case-specification)
                                      source)))

;;see fire\flat-files\cyc\..\resources\economic-preds.txt
(defmethod gather-dgroup-facts ((type (eql 'data::EconomicCaseFn))
                                (specs list)
                                (source analogy-source))
  (gather-economic-case-dgroup (car specs) source))

(defmethod gather-dgroup-facts ((type (eql 'data::economic-case-fn))
                                (specs list)
                                (source analogy-source))
  (gather-economic-case-dgroup (car specs) source))

(defun gather-economic-case-dgroup (case-name source)
  (ask `(data::and (data::assertedTermSentences ,case-name ?s)
             (data::operatorFormulas ?op ?s)
             (data::isa ?op data::EconomicPredicate))
       (reasoner source)
       :any ;; context
       :all ;; number
       '?s
       :lookup))

;;Note arity = 2
(defmethod gather-dgroup-facts ((type (eql 'data::CaseUnionFn))
                                (specs list)
                                (source analogy-source))
  (gather-case-union-dgroup specs source))

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

(defun gather-case-union-dgroup (case-name source)
  (gather-case-set-operated-dgroup 'union case-name source))

;;Note arity = 2
(defmethod gather-dgroup-facts ((type (eql 'data::CaseIntersectionFn))
                                (specs list)
                                (source analogy-source))
  (gather-case-intersection-dgroup specs source))

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


(defun gather-case-intersection-dgroup (case-name source)
  (gather-case-set-operated-dgroup #'intersection case-name source))



;;Note arity = 2
;;(CaseComplementFn <superset> <subset>)

(defmethod gather-dgroup-facts ((type (eql 'data::CaseComplementFn))
                                (specs list)
                                (source analogy-source))
  (gather-case-complement-dgroup specs source))

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

(defun gather-case-complement-dgroup (case-name source)
  (gather-case-set-operated-dgroup #'set-difference case-name source))


(defun gather-case-set-operated-dgroup (set-op cases source)
  (let* ((first-case-name (car cases))
        (first-case (gather-dgroup-facts  (car first-case-name) (cdr first-case-name) source))
        (second-case-name (second cases))
         (second-case (gather-dgroup-facts  (car second-case-name) (cdr second-case-name) source)))
    (cond ;; no mixed explicit and dynamic
          ((or (and (explicit-case? first-case-name)
                    (explicit-case? second-case-name))
               (and (not (explicit-case? first-case-name))
                    (not (explicit-case? second-case-name))))
           (funcall set-op 
                    first-case
                    second-case
                    :test 'equal))
          
          ;; mixed - wrap ist-Information around explicit case statements
          ;; and then unwrap
          (t (mapcar #'third
               (funcall set-op 
                        (make-ist-wrapper-if-explicit first-case-name first-case)
                        (make-ist-wrapper-if-explicit second-case-name second-case)
                        :test 'equal))))))

(defun make-ist-wrapper-if-explicit (case-name case-facts)
  (if (explicit-case? case-name)
                          (mapcar #'(lambda (fact)
                                      (make-case-fact (second case-name) fact))
                            case-facts)
                          case-facts))


(defun explicit-case? (term)
  (or (eq (car term)
          'data::ExplicitCaseFn)
      (eq (car term)
          'data::explicit-case-fn)))              


(defmethod gather-dgroup-facts ((type t)
                                (args list) 
                                (source analogy-source))
  (let ((assertion (car (fire::ask-it `(data::caseConstructionFor ,type ?args ?mech)
                                      :response :pattern :reasoner (reasoner source)))))
    ;; ** add make-case-construction ... in make-exp 
    (cond (assertion
           (let ((fargs (cdr (third assertion)))   ;;fargs are originally of the form (TheList ?x)
                 (mech (fourth assertion)))
             (and (= (length fargs) (length args))
                  (not (some 'variable? args))
                  (do ((formal-args fargs (cdr formal-args))
                       (actual-args args (cdr actual-args))
                       (contents mech (subst (car actual-args) (car formal-args) contents)))
                      ((or (null formal-args)
                           (null actual-args))
                       (let ((facts (fire::ask-it (third contents)
                                                  :response :bindings 
                                                  :reasoner (reasoner source))))
                         (setf facts (mapcar 'cdar facts))
                         (let ((case-name (cons type args)))
                           ;; We don't really know what the arguments are for some of these more
                           ;; complex constructors. But what we are going to do is to use the
                           ;; whole NAT as their name, because then we have a record of the result
                           ;; of the computation.  We don't use a name for ExplicitCaseFn because
                           ;; that is an extremely common situation for things we construct all
                           ;; the time.  
                           (dolist (fact facts)
                             (tell-it (make-case-fact case-name fact) :reasoner (reasoner source)))
                           facts))))))))))

;; (fire:store '(caseConstructionFor EconomicCaseFn (TheList ?seed) 
;;;;  (TheSetOf ?sentence (and (assertedTermSentences ?seed ?sentence)
;;;;;;  (operatorFormulas genls ?sentence)))) fire:*kb*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Refreshing dgroup

(defun get-updated-dgroup (dgroup source)
  (let ((dgroup-term (sme:name dgroup)))
    (add-facts (gather-dgroup-facts (car dgroup-term)
                                    (cdr dgroup-term) source)
               dgroup
               source)))
  
(defun add-facts (facts dgroup source)
  (multiple-value-bind (entities expressions)
      (extract-entities-and-expressions facts source)
    (dolist (entity entities)
      (sme::define-entity entity dgroup))  
    (dolist (expression expressions)
      (sme::define-expression expression dgroup))
    dgroup))
       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Experiment. Support for the ISA <-> attribute translation needs to
;;; be available at the purely SME level, to handle dehydrated SME's
;;; properly.  This code tweaks the expression definition just slightly
;;; to handle this case.  


(defclass sme::description-w-isa-support (sme::description)
  ())

(defmethod sme::define-expression :around 
  ((user-form list) ;; Was t, but that's unsafe
   (description sme::description-w-isa-support)
   &optional expression-id)
  (call-next-method
   (if (fire->sme-translation-needed? user-form) 
     (fire->sme (car user-form) (cdr user-form))
     user-form)
   description expression-id))  

(defun rehydrate-sme (input-file)
  (sme::with-sme-description-type 'sme::description-w-isa-support
                                  (load input-file)
                                  sme:*sme*)
  sme:*sme*)

(defmethod sme::create-description-item (form role description (vocabulary analogy-source))
  (declare (type sme::description sme::description))
  (let ((the-role (if (listp role) (sme::case-relation role) role)))
  ;; We use the FIRE KB to figure out what kind of thing each must be.  
  (cond ((atom form)
         ;; It's either a predicate or an entity.
         (cond ((predicate-type form :kb (kb vocabulary))
                ;; This is a fairly subtle issue.  In some ways it would be best to
                ;; use the relationship here, i.e., 
                ;; (sme::find-predicate form vocabulary)
                ;; However, predicates don't have order, and since the same predicates
                ;; may appear as functors, we need to think about how we are handling this.
                ;; For example, do we really want to mapping implies to equalTo in some 
                ;; metaphorical sense to change the way that implies itself is used in 
                ;; making arguments about the implications of the metaphor?  I doubt it.
                ;; Hence treating predicates as entities when they are used as higher-order
                ;; entities seems to be the most sensible.
                (sme::make-expr-arg the-role (sme::define-entity form description)))
               (t (sme::make-expr-arg the-role
                                 (sme::define-entity form description)))))
        ((non-atomic-term? form)
         ;; ***** Make sure this is done uniformly with other NAT handling.
         (cond ((kappa-form? form) ;; Treat as an entity, as per arguments above
                (sme::make-expr-arg the-role
                               (sme::define-entity form description)))
               (t (sme::make-expr-arg the-role (sme::define-entity form description)))))
        (t (let ((entity (sme::fetch-entity form description)))
             (cond (entity (sme::make-expr-arg the-role entity))
                   (t (let ((subexp (sme::define-expression form description)))
                        (if (null subexp) (throw 'argument-arity-error nil)
                          (sme::make-expr-arg the-role subexp))))))))))

(defun list-explicit-cases (&optional (kb fire::*kb*))
  ;; For debugging and exploration
  (let ((case-names nil))
    (dolist (form (retrieve-pattern '(data::ist-Information ?case-name ?fact)
                                          :kb kb)
                  case-names)
      (pushnew (cadr form) case-names :test 'equal))))

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