;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: content-vector.lsp
;;;;    System: FIRE v1
;;;;   Version: 2.0
;;;;    Author: Ken Forbus
;;;;   Created: December 30, 2000 22:55:41
;;;;   Purpose: Content vector utilities
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Tuesday, February 3, 2004 at 09:26:03 by Ken Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;; Each functor is a feature.  Its strength in a content vector is
;;; proportional to the number of occurrences in the original description.
;;; The dot product of two content vectors is a good approximation to the
;;; number of match hypotheses SME would compute for the two descriptions.

;;; As in the standalone MAC/FAC implementation, we actually use two kinds of
;;; content vectors.  Basic CV's are unnormalized, from which the actual CV's
;;; are computed by subtracting out ubiquitious predicates.  
 
;;; Computing content vectors for KB storage
;;; We don't want to go to the expense of computing dgroups for everything we're
;;; storing, so we need to make the computation work just on the facts plus KB
;;; properties

(defclass content-vector ()
  ((case-term :type t :initform nil :initarg :case-term :accessor case-term
                :documentation "The term for the case this content vector summarizes.")
   (fact-count :type integer :initform 0 :initarg :fact-count :accessor fact-count
               :documentation "Number of facts in this case.")
   (cv-magnitude :type float :initform 0.0 :initarg :cv-magnitude :accessor cv-magnitude
         :documentation "Magnitude of the content vector")
   (cv-entries :type t :initform nil :initarg :cv-entries :accessor cv-entries
               :documentation "Alist of (<sc entry predicate> . <# of occurrences>)")))

(defmethod print-object ((o content-vector) (stream t))
  (format stream "<cv:~A,~D,~D>" (case-term o) (fact-count o) (cv-magnitude o)))

(defmethod sc-entry< ((p1 t) (p2 t)) (error "Not both sc-entries:~A, ~A." p1 p2))

(defmethod sc-entry< ((p1 sc-entry) (p2 sc-entry)) (< (sc-id p1) (sc-id p2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creating content vectors
;;; There are two ways content vectors will be created.  
;;; First, we may have the facts of a case, but not bother building a dgroup because it
;;; isn't clear whether or not that case will ever be retrieved.  So why build the dgroup
;;; datastructure until SME needs it?
;;; Second, we may be incrementally building it up, either because we are doing incremental
;;; retrievals based on changing contents of working memory, or because we are initializing
;;; a set of context vectors for some subset of the KB (or the whole thing).  
;;; To handle both cases, 
;;;  (add-fact-to-content-vector <cvector> <fact>) extends <cvector> by <fact>.
;;;  (remove-fact-from-content-vector <cvector> <fact>) removes <fact> from <cvector>.
;;;
;;; Notice that there isn't any cheap way of keeping track what fact is or is not in
;;; the content vector.  Kind of annoying.  If there are repeated subexpressions, do we want
;;; to double-count them?  This isn't what we did before.  But it would capture a bit of the
;;; bias given to common sub-structure, so we'll try it this way as an experiment.

(defun make-cv-from-facts (case-term fact-list)
  (let ((cv (make-instance 'content-vector :case-term case-term)))
    (add-fact-set-to-content-vector cv fact-list :translate? t)
    cv))

(defun make-normalized-cv-from-dgroup (dgroup source)
  (normalize-cv (make-cv-from-dgroup dgroup) source))

(defun make-cv-from-dgroup (dgroup)
  (let ((cv (make-instance 'content-vector :case-term (sme::name dgroup))))
    (add-fact-set-to-content-vector cv (cdr (sme::lisp-form dgroup))
                                    :translate? nil)
    cv))

(defmethod add-fact-to-content-vector ((cv t) (item t) &key (kb *kb*)) 
  (declare (ignore kb))
   nil)

(defmethod add-fact-to-content-vector ((cv content-vector) (item list)
                                       &key (kb *kb*)
                                       (translate? t))
  (let ((translated-item (if translate?
                           (fire->sme-expression item) item)))
    (when item 
      (incf (fact-count cv))
      (add-to-content-vector cv translated-item :kb kb)
      (update-cv-magnitude cv)
      cv)))

(defmethod add-fact-set-to-content-vector ((cv content-vector)(set-of-items list)
                                           &key (kb *kb*) (translate? t))
  (incf (fact-count cv) (length set-of-items))
  (dolist (fact set-of-items) 
    (add-to-content-vector cv (if translate? (fire->sme-expression fact)
                                fact) :kb kb))
  (update-cv-magnitude cv)
  cv)

(defmethod add-to-content-vector ((cv t) (item t) &key (kb *kb*))
  (declare (ignore kb))
  nil)

(defmethod add-to-content-vector ((cv content-vector) (item list) &key (kb *kb*))
  (let* ((predicate (car item))
         (entry (find-sc-entry predicate kb)))
    (when (sc-predicate? entry)
       (let ((cv-entry (find-or-make-cv-entry entry cv)))
        (incf (cdr cv-entry))
        (dolist (arg (cdr item))
          (add-to-content-vector cv arg :kb kb))))))

(defun find-or-make-cv-entry (sc-entry cv)
  (let ((cv-entry (assoc sc-entry (cv-entries cv))))
    (cond (cv-entry cv-entry)
          (t (setq cv-entry (cons sc-entry 0))
             (setf (cv-entries cv)
               (merge 'list (list cv-entry) (cv-entries cv)
                      'sc-entry< :key 'car))
             cv-entry))))

(defun update-cv-magnitude (cv)
  (let ((magnitude 0.0))
    (dolist (cv-entry (cv-entries cv) (setf (cv-magnitude cv)
                                        magnitude))
      (incf magnitude (* (cdr cv-entry) (cdr cv-entry))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Handling removal of facts

(defmethod remove-fact-from-content-vector ((cv t) (item t) &key (kb *kb*))
  (declare (ignore kb))
  nil)

(defmethod remove-fact-from-content-vector ((cv content-vector) (item list) &key (kb *kb*))
  (decf (fact-count cv))
  (remove-from-content-vector cv item :kb kb))

(defmethod remove-from-content-vector ((cv t) (item t) &key (kb *kb*))
  (declare (ignore kb))
  nil)

(defmethod remove-from-content-vector ((cv content-vector) (item list) &key (kb *kb*))
  (let* ((predicate (car item))
         (entry (find-sc-entry predicate kb)))
    (when (sc-predicate? entry)
      (let ((cv-entry (find-or-make-cv-entry entry cv)))
        (cond ((< (cdr cv-entry) 1)) ;; Already taking out too much
              ;; Should signal some kind of complaint.
              (t (decf (cdr cv-entry))
                 (dolist (arg (cdr item))
                   (remove-from-content-vector cv arg :kb kb))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Display and debugging code

(defmethod show ((cv content-vector) &key (stream *standard-output*) (size? nil))
  (format stream "~%(CV ~A):~%" (case-term cv))
  (format stream "~& #Facts = ~D, #Entries = ~D.~%" (fact-count cv) (length (cv-entries cv)))
  (dolist (cv-entry (if size? (sort (copy-list (cv-entries cv)) 
                                    #'(lambda (e1 e2)
                                        (> (cdr e1) (cdr e2))))
                      (cv-entries cv)))
    (format stream "~&  ~A: ~D~%" (sc-item (car cv-entry))
      (cdr cv-entry))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Dot product
;;;
;;; We assume that, whatever their source, any appropriate scaling, filtering, or
;;; normalization has already been done.

(defun cv-dot-product (cv1 cv2)
  (do ((one (cv-entries cv1))
       (two (cv-entries cv2))
       (product 0.0))
      ((or (null one) (null two)) product)
    (let* ((e1 (car one))
           (p1 (car e1))
           (v1 (cdr e1))
           (e2 (car two))
           (p2 (car e2))
           (v2 (cdr e2)))
      (cond ((< (sc-id p1) (sc-id p2)) (setq one (cdr one)))
            ((> (sc-id p1) (sc-id p2)) (setq two (cdr two)))
            (t (incf product (* v1 v2))
               (setq one (cdr one) two (cdr two)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Using content vectors with specific reasoners
;;;
;;; Given a task, the set of ubiquitous predicates and/or internal predicates
;;; (as indicated by NotForAnalogyPredicate membership) can be different.
;;; We want to renormalize the content vector to provide maximum discriminability.
;;; Observation: The ubiquitous and internal predicates won't exist in the probe,
;;; since that presumably is created by the reasoner based on WM contents. 
;;; 2nd observation: The set of predicates to be ignored changes slowly.
;;; 3rd observation: We want these sets to be as uniform as possible.
;;;
;;; Strategy: Keep a renormalized set of cv-entries for a content vector on demand, cached
;;; with the reasoner.  They will include the list of predicates to ignore, as well as a corrected
;;; magnitude to compute with.  This cache will not be persistent, i.e., it will not be dumped
;;; when the case library is dumped.  That's because it should be reasonably quick to recompute
;;; given the basic CV's stored persistently in theh KB.
;;;
;;; An open question is whether or not it is worth copying the whole cv-entry list for a set of
;;; filtered predicates, or just test when doing the dot product.  The problem with testing during
;;; the dot product is that this will require a linear search, unless we tag the SC entry with some
;;; property that is quick to check.  (list of reasoners it is filtered out for?) The problem with
;;; with copying is that that could get quite expensive in terms of memory usage, esp. with context
;;; vectors or really large cases.  Probably should implement it both ways and just find out...
;;; There is also the possibility that the task involves no additional ubiquituous or internal 
;;; predicates, and in that case we ought to use the vector from the KB as is.

(defun copy-cv (cv-in)
  (make-instance 'content-vector :case-term (case-term cv-in)
    :fact-count (fact-count cv-in)
    :cv-magnitude (cv-magnitude cv-in)
    :cv-entries (copy-tree (cv-entries cv-in))))

(defun normalize-cv (cv analogy-source)
  ;; Normalization is done w.r.t. an analogy source so that 
  ;; we can filter out internal predicates
  (setf (cv-entries cv)
    (delete-if 
     #'(lambda (cv-entry)
         (or (ubiquitous-predicate? (car cv-entry) analogy-source)
             (internal-predicate? (car cv-entry) analogy-source)))
     (cv-entries cv)))
  (update-cv-magnitude cv)
  (scale-cv-entries cv)
  cv)

(defun scale-cv-entries (cv) 
  (let ((magnitude (sqrt (cv-magnitude cv))))
    (dolist (entry (cv-entries cv) cv)
      (setf (cdr entry) (/ (cdr entry) magnitude)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Storing and removing CV's
;; Content vector assertions are not intended for external use,
;; and we'll probably be storing them in specialized tables before
;; long.  So we'll go straight to the database API for this.

;;; YOU ARE HERE
;;; ****** Use genlPreds for filtering?
;;; ****** Persistent case libraries cached with KB
;;; ****** Caching content vectors for case libaries with analogy sources in reasoners.
;;; ****** Add some queries that can be used to inspect properties of case libraries (e.g., how many
;;;  cases, how big they are), both for control reasoning and for testing the case library
;;;  construction processes.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Some debugging/exploration utilities

(defun show-cv-cross-products (cv-list)
  "Returns result of doing dot products across a set of cvectors"
  (sort (recursive-cv-cross-products cv-list) '> :key 'third))

(defun recursive-cv-cross-products (cv-list)
  (cond ((null cv-list) nil)
        ((null (cdr cv-list)) nil)
        (t (nconc (mapcar #'(lambda (other)
                              (list (car cv-list) other
                                    (cv-dot-product (car cv-list) other)))
                    (cdr cv-list))
                  (recursive-cv-cross-products (cdr cv-list))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Old procedures -- kept for comparison purposes.
;;;; We'll want to do an analysis of the new versus old way of computing
;;;; content vectors, and tweaking this code will be the best way to do that.

(defun old-compute-basic-cv (facts &optional (kb *kb*))
  (with-kb kb ;; not necessary currently, but if we stash id's with preds
    ;; or have to use KB for dealing better with NAT's, this will be useful.
    (let ((cvector nil)
          (entry nil)
          (predicate nil))
      (dolist (expression (unique-expressions facts))
        (setq predicate (car expression))
        (setq entry (assoc predicate cvector :test 'equal))
        (unless entry
          (setq cvector
                (merge 'list (list (setq entry (cons predicate 0)))
                       cvector
                       #'(lambda (e1 e2) (predicate< (car e1) (car e2))))))
        (incf (cdr entry)))
      cvector)))

;; Crucial for sparse vector representation
(defmethod predicate< ((f1 number) (f2 number))
   (< f1 f2))

(defmethod predicate< ((f1 symbol) (f2 symbol))
  (string< (symbol-name f1) (symbol-name f2)))

(defmethod predicate< ((f1 t) (f2 t))
  ;; Hideously expensive -- hope we don't do often!
  (string< (format nil "~S" f1) (format nil "~S" f2)))

(defun unique-expressions (facts)
  (remove-duplicates (mapcan 'subexpressions-of facts)
                     :test 'equal))

(defun subexpressions-of (fact)
  (cond ((null fact) nil)
        ((not (listp fact)) nil)
        ((listp (car fact)) ;; something more complex
         ;; This would have to be a kappa or lambda.  We won't
         ;; look inside.
         (mapcan 'subexpressions-of (cdr fact)))
        ((isa-predicate? (car fact)) ;; do isa->attribute
         ;; conversion on the fly here
         (list (list (third fact) (second fact))))
        (t (nconc (list fact)
                  (mapcan 'subexpressions-of (cdr fact))))))




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