;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: analogy-source.lsp
;;;;    System: FIRE
;;;;   Version: v1
;;;;    Author: Ken Forbus
;;;;   Created: December 13, 2000 13:57:13
;;;;   Purpose: Provide analogy services for FIRE
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Saturday, April 10, 2004 at 20:04:10 by usher
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Class Definitions

(defclass analogy-source (source)
  ((smes :type list :initform nil :accessor smes
         :documentation "List of SMEs created by this source.")
   (retrievals :type list :initform nil :accessor retrievals
               :documentation "List of retrievals created by this source.")
   (case-libraries :type list :initform nil :accessor case-libraries
                   :documentation "List of case libraries used by this source.")
   (internal-predicates :type list :initform nil :accessor internal-predicates
     :documentation "List of internal predicates for this reasoner.")
   (ubiquitous-predicates :type list :initform nil :accessor ubiquitous-predicates
     :documentation "List of ubiquitious predicates for this reasoner.")
   (dgroups :type list :initform nil :accessor dgroups
            :documentation "List of dgroups created in this source.")
   (dgroup-counter :type t :initform -1 :accessor dgroup-counter
                   :documentation "ID counter for dgroups.")
   (basic-cvectors :type t :initform nil :accessor basic-cvectors
                   :documentation "Cache of basic content vectors from KB")
   (cvectors :type t :initform nil :accessor cvectors
             :documentation "Normalized content vectors ready for MAC")
   (max-minimal-ascension-depth :type t :initform nil
                                :initarg :max-minimal-ascension-depth
                                :accessor max-minimal-ascension-depth
    :documentation "Maximum depth for minimal ascension. NIL = off.")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Making new analogy sources

(defun get-new-dgroup-id (source) (incf (dgroup-counter source)))

(defmethod sme::ubiquitous-predicates ((vocabulary analogy-source))
  (ubiquitous-predicates vocabulary))

(defmethod analogy-source? ((thing t)) nil)
(defmethod analogy-source? ((thing analogy-source)) t)

(defmethod analogy-source-of ((thing t)) nil)
(defmethod analogy-source-of ((thing reasoner))
  (dolist (source (sources thing))
    (when (analogy-source? source)
      (return-from analogy-source-of (values source)))))

(defvar *analogy-source* nil) ;; Global register

(defmacro with-analogy-source (source &rest forms)
  `(let ((*analogy-source* ,source)) ,@ forms))

;; **** Issue: How to tell when the dgroup cache is dirty?

(defmethod add-analogy-source ((reasoner reasoner) &key (type 'analogy-source))
  (let ((source (make-instance type :reasoner reasoner)))
    (add-source source reasoner)
    ;; (match-between ?base ?target ?constraints ?match)
    ;;run-basic-sme handles all the queries. 
    ;;Making separate functions leads to lot of code duplication.
    (register-matcher-handlers source reasoner)
    (register-case-handlers source reasoner)
    (register-mapping-handlers source reasoner)
    (register-correspondence-handlers source reasoner)
    (register-candidate-inference-handlers source reasoner)
    (register-reminding-handlers source reasoner)
    source))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Running SME

(defun run-basic-sme (source context number response effort
                             query base target given-constraints)
  (declare (ignore number effort))
  ;; ?match is the only unknown, and it is what is produced.
  (update-ubiquitous-preds! source)
  (update-internal-preds! source)
  (sme:with-vocabulary source
    (let* ((base (get-dgroup base source))
           (target (get-dgroup target source))
           (constraints (cond ((and (or (match-between-exp? query)
                                        (seeking-match-between-exp? query)
                                    (listp given-constraints)))
                               (cdr given-constraints))
                              ((filtered-match-between-exp? query)
                               (get-sme-filter-fn given-constraints))
                              (t nil)))
           (sme (sme::define-sme base target 
                  :sme-type (if (strong-filtered-match-between-exp? query)
                              'sme::strong-filtering-sme sme::*sme-type*))))
      (push sme (smes source))
      (sme:match-with-appropriate-filters sme constraints)
      (reify-sme sme source) ;; cache results in ltre
      (make-sme-result source query response context sme))))

(defun make-sme-result (source query response context sme)
  (let* ((binding-list (list (cons (fifth query) (make-sme-reference sme))))
         (bound-result (sublis binding-list query)))
    ;; Cache result in reasoner
    (tell bound-result (reasoner source) :analogy-source context)
    ;; Return whatever was requested.  N.B. Although we are computing
    ;; only a single answer, source handlers need to return a list since
    ;; in general there can be more than one.
    (list (case response
            (:bindings binding-list)
            (:pattern (sublis binding-list query))
            (t (sublis binding-list response))))))

(defun match-between-exp? (exp)
  (or (eq (car exp)
          'data::matchBetween)
      (eq (car exp)
          'data::match-between)))

(defun seeking-match-between-exp? (exp)
  (or (eq (car exp)
          'data::seekingMatchBetween)
      (eq (car exp)
          'data::seeking-match-between)))

(defun filtered-match-between-exp? (exp)
  (or (eq (car exp)
          'data::filteredMatchBetween)
      (eq (car exp)
          'data::filtered-match-between)))

(defun strong-filtered-match-between-exp? (exp)
  (or (eq (car exp)
          'data::strongFilteredMatchBetween)
      (eq (car exp)
          'data::strong-filtered-match-between)))

(defun re-match-between-exp? (exp)
  (or (eq (car exp)
          'data::reMatchBetween)
      (eq (car exp)
          'data::re-match-between)))

(defun update-match-between-exp? (exp)
  (or (eq (car exp)
          'data::updateMatchBetween)
      (eq (car exp)
          'data::update-match-between)))

(defun get-sme-filter-fn (filter-fn-desc)
  ;; right now we can only handle descriptions of the form 
  ;; (ExecutableFunctionFn <function-name>)
  (cond ((and (listp filter-fn-desc)
              (eq (car filter-fn-desc)
                  (if (mixed-case?) 
                    'data::ExecutableFunctionFn
                    'data::executable-function-fn)))
         (second filter-fn-desc))
        (t nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Handling ubiquitious and internal predicates
;;;
;;; Ubiquitous predicates can appear in dgroups, but they are not in themselves sufficient
;;; evidence to cause two statements to be placed into alignment.  If, however, they are part
;;; of some larger structure, then that is okay.
;;;
;;; Internal predicates are statements that shouldn't appear in analogical processing
;;; operations at all.  Things like comments and metadata, for example.  Currently we 
;;; discard any statement that has a subexpression using an internal predicate.  That may
;;; be a bit too strong: We may be better off using something like the antecedent filtering
;;; used in structured explanation systems.
;;;
;;;***** Issue: The updates for ubiquitous and internal predicates
;; *****   below don't take into account the fact that ASK caches results
;; *****   in the LTRE.  This caching is a great performance advantage when we aren't
;; *****   changing these rapidly, but a potential source of bugs if we are either
;; *****   changing these choices during development or we start dynamically determining
;; *****   them.  Might have to set a flag (or assertion) about whether or not it is safe
;; *****   to cache.

(defun update-ubiquitous-preds! (source)
  "Changes the list of ubiquitous predicates.  Note that this completely
   updates the list since some of the assertions denoting ubiq preds
   may have been added or retracted."
  (let ((preds (ask (make-ubiquitous-predicate-query 'data::?x)
                    (reasoner source) :any :all 'data::?x :lookup))
        (u-preds nil)
        (sme-pred nil))
    (dolist (pred preds)
      (setq sme-pred (sme:find-predicate pred source))
      (when sme-pred
        (push (sme::id sme-pred) u-preds)))
    (setf (ubiquitous-predicates source) u-preds)))

(defmethod ubiquitous-predicate? ((thing t) (source t)) nil)

(defmethod ubiquitous-predicate? ((thing sc-entry) (source analogy-source))
  (member (sc-id thing) (ubiquitous-predicates source)))

(defmethod ubiquitous-predicate? ((thing list) (source analogy-source))
  (ubiquitous-predicate? (find-sc-entry thing (kb source))
          source))

(defmethod ubiquitous-predicate? ((thing symbol) (source analogy-source))
  (ubiquitous-predicate? (find-sc-entry thing (kb source))
                         source))

;;;(defun update-internal-preds! (source)
;;;  "Computes the list of internal predicates, meaning predicates that are used
;;;   for internal system computations and shouldn't be exposed for analogical
;;;   processing.  This will prevent them from appearing in dgroups."
;;;  (let ((preds (ask '(data::isa data::?x data::NotForAnalogyPredicate)
;;;                    (reasoner source) :any :exhaustive 'data::?x :lookup)))
;;;    (setf (internal-predicates source) preds)))
;;;
;;;(defun update-internal-preds! (source)
;;;  (let ((preds (retrieve '(data::isa data::?x data::NotForAnalogyPredicate))))
;;;    (setf (internal-predicates source) (mapcar 'cadr preds))))
;;; Old versions illustrate how much simpler the new structural cache makes things:

(defun update-internal-preds! (source &key (kb *kb*))
  (let ((internal-pred-ids nil))
    (dolist (sc-pred (instances-of-sc 'd::NotForAnalogyPredicate :kb kb))
      (push (sc-id sc-pred) internal-pred-ids))
    (dolist (pred (ask '(d::isa ?pred d::NotForAnalogyPredicate)
                       (reasoner source) :any :all '?pred :wm-only))
      (push (sc-id (find-or-make-sc-entry pred kb)) internal-pred-ids))
    (setf (internal-predicates source) internal-pred-ids)))

(defmethod internal-predicate? ((thing t) (source t)) nil)

(defmethod internal-predicate? ((thing sc-entry) (source analogy-source))
  (member (sc-id thing) (internal-predicates source)))

(defmethod internal-predicate? ((thing list) (source analogy-source))
  (internal-predicate? (find-sc-entry thing (kb source))
          source))

(defmethod internal-predicate? ((thing symbol) (source analogy-source))
  (internal-predicate? (find-sc-entry thing (kb source))
                         source))

;;; For experimental purposes

(defun assume-ubiquitous-wm (pred &optional (reasoner *reasoner*))
  (ltre::with-ltre (ltre reasoner)
    (ltre:assume! `(data::isa ,pred data::UbiquitousPredicate) :user)))

(defun retract-ubiquitous-wm (pred &optional (reasoner *reasoner*))
  (ltre::with-ltre (ltre reasoner)
    (ltre::retract! `(data::isa ,pred data::UbiquitousPredicate) :user)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MAC/FAC

(defun run-macfac (source context number response effort query
                          probe library)
  (declare (ignore number effort context))
  ;; Query is of the form (reminding ?probe ?library ?case ?match ?reminding)
  ;; where ?probe and ?library are known and ?case, ?match, and ?reminding are
  ;; computed by this procedure.
  ;; ***** Well, soon.  The reminding structure isn't installed yet, because
  ;; ***** I need to get the rest of these updates checked in.
  (let* ((outputs (macfac probe library source))
         (results (reify-macfac probe library outputs source)))
    (declare (ignore results))
    ;; Cache SME's with source for future reference
    (dolist (output outputs) (push (third output) (smes source)))
    ;; We know the vars are (reminding <probe> <lib> ?case ?match)
    (let* ((binding-lists 
            (mapcar #'(lambda (output)
                        (list (cons (fourth query) (sme::name (cadr output)))
                              (cons (fifth query) (make-sme-reference
                                                   (third output)))))
              outputs))
           (bound-results (mapcar #'(lambda (bl)
                                      (sublis bl query)) binding-lists)))
      ; Return whatever was requested
      (case response
        (:bindings binding-lists)
        (:pattern bound-results)
        (t (mapcar #'(lambda (bl)
                       (sublis bl response)) binding-lists))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End Of Code