;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                    -*-
;;;; ---------------------------------------------------------------------
;;;; File name: context-vector.lsp
;;;;    System: FIRE
;;;;    Author: Praveen Paritosh
;;;;   Created: July 17, 2002 02:25:23
;;;;   Purpose: Mechanism for finding associations
;;;; ---------------------------------------------------------------------
;;;;  Modified: Friday, September 20, 2002 at 16:07:21 by paritosh
;;;; ---------------------------------------------------------------------

;; WARNING: Work in Progress, Do Not Use. 

(in-package :fire)

;;;* Context Vectors
;;;  Context vectors are a mechanism to find associations between two 
;;;  concepts. The key idea is very simple. Given a symbol (that represents
;;;  a concept in the KB), we retrieve all the assertions in the KB that 
;;;  mention the concept. From these, we compute a list of features. Features
;;;  are all the symbols and NARTs in the assertions that were found (if it
;;;  is a NART, we dont look inside it). Also, there is a list of predicates
;;;  that we think are non-discriminatory (e.g. AND, OR, argIsa, cyclistNotes,
;;;  etc.) that dont count as features. (Note: It is an empirical question as 
;;;  to what should count as features for the purpose of building the context
;;;  vectors, and what should not. This is subject to change/modifications).
;;;  Once from the list of assertions we have built the list of context-vector-
;;;  features, then we compute the context vector which is a hash table whose
;;;  keys are features and values are the frequency count of that feature over
;;;  the list of all assertions in KB that mentioned the symbol for which we 
;;;  are building the context vector. The context vector can be normalised, 
;;;  where we divide these frequency values by sum of squares of all the 
;;;  frequency counts. We can also compute a dot product between two context
;;;  vectors which is the sum of dot products of features that are present 
;;;  in both the context vectors. It is obvious that the dot product of two
;;;  context vectors can be utmost 1 when they are identical. 
;;;
;;;* How to use it? 
;;;  There are two ways to use it. First is when you have are interested in 
;;;  computing a particular association, and the second is when you have a 
;;;  list of symbols and you want to build an association matrix, such that 
;;;  each entry in the matrix is the association between the concept in the
;;;  corresponding row and column. The association matrix is symmetric and 
;;;  the diagonal elements are all 1.
;;;
;;;  Single Use: 
;;;  (compute-context-vector <symbol> :reasoner <reasoner>) 
;;;     Returns two values: the basic and the normalised context vectors
;;;  (normalize-context-vector <basic-context-vector>)
;;;     Destructively normalises the frequency values by the sum of square 
;;;     of all the frequency values in the basic context vector. 
;;;  (safe-normalize-context-vector <basic-context-vector>)
;;;     Same as above, but returns a copy instead of being destructive.
;;;  (context-vector-dot-product <cxv1> <cxv2>)
;;;     Returns a scalar number which is the dot product of the two vectors.
;;;     If they were normalised to begin with, this number is between 0 
;;;     and 1.
;;;
;;;  Batch Usage: The key difference is heavy caching, and output format, 
;;;  which is a matrix here. 
;;;  (make-assoc-matrices <symlist> :reasoner <reasoner> 
;;;                                 :retrieve-refs-cache 
;;;				 :basic-context-vectors-cache
;;;				 :normalized-context-vectors-cache)
;;;    The <symlist> is the list of symbols for which you want build the
;;;    assoc matrix. The retrieve-refs-cahce, basic-context-vectors-cache, 
;;;    and normalized-context-vectors-cache are initialised by default to 
;;;    fire::*retrieve-refs-cahce*, fire::*basic-context-vectors-cache*, 
;;;    and fire::*normalized-context-vectors-cache* respectively. These 
;;;    are hash tables that cache the intermediate computations that are 
;;;    re-used. make-assoc-matrices returns two values, the basic-assoc-matrix
;;;    and the normalized-assoc-matrix.
;;;  (save-assoc-matrix <symlist> <assoc-matrix> <filename>)
;;;     Saves the assoc-matrix to disk, using the symbols in the symlist to 
;;;     produce the row and column labels. The <filename> is the string that
;;;     denotes the full path of the file where you want to save the matrix.
;;;     This can then later be read as a spreadsheet, for example. 

(defvar *retrieve-refs-cache* (make-hash-table :test 'equal))
(defvar *basic-context-vectors-cache* (make-hash-table :test 'equal))
(defvar *normalized-context-vectors-cache* (make-hash-table :test 'equal))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Computing the context vectors and the dot products
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Make the context-vector a hash table. That gets rid of the sorting time. 

(defun compute-context-vector (sym &key (reasoner *reasoner*) (retrieve-refs-cache *retrieve-refs-cache*))
  (let* ((facts (retrieve-references-using-cache sym :kb (kb reasoner) :retrieve-refs-cache retrieve-refs-cache))
         (features (delete sym (compute-context-vector-features facts reasoner)))         
         (context-vector (make-hash-table :test 'equal)))
    (dolist (feature features context-vector)
      (multiple-value-bind (value present-p) (gethash feature context-vector)
        (if present-p 
          (incf (gethash feature context-vector))
          (setf (gethash feature context-vector) 1))))))

(defun compute-context-vector-features (term reasoner)
  (cond ((null term) nil)
        ((not-for-associations? term reasoner) nil)
        ((not (consp term)) (list term))
        ;; Now it can be a NART, or not. If a NART, we insert
        ;; into the context vector as such, else we go inside. 
        (t (if (nart-predicate? (car term)) 
             (list term) 
             (append
              (compute-context-vector-features (car term) reasoner)
              (compute-context-vector-features (cdr term) reasoner))))))


(defun context-vector-dot-product (cxv1 cxv2)
  (if (< (hash-table-count cxv1) (hash-table-count cxv2))
    (context-vector-dot-product-1 cxv1 cxv2)
    (context-vector-dot-product-1 cxv2 cxv1)))

(defun context-vector-dot-product-1 (cxv1 cxv2)
  (let ((sum 0))
    (maphash #'(lambda (key1 value1)
                 (multiple-value-bind (value2 present-p) (gethash key1 cxv2)
                   (if present-p (incf sum (* value1 value2))))) cxv1)
    (values sum)))

;; Destructively normalizes the context-vector
(defun normalize-context-vector (context-vector)
  (let ((sqrsum 0))
    (maphash #'(lambda (key val)
                 (incf sqrsum (* val val))) context-vector)
    (let ((magnitude (sqrt sqrsum)))
      (maphash #'(lambda (key val)
                   (setf (gethash key context-vector) (/ val magnitude))) context-vector))
    (values context-vector)))

(defun safe-normalize-context-vector (context-vector)
  (let ((sqrsum 0))
    (maphash #'(lambda (key val)
                 (incf sqrsum (* val val))) context-vector)
    (let ((magnitude (sqrt sqrsum))
          (normalized-context-vector (make-hash-table :test 'equal)))
      (maphash #'(lambda (key val)
                   (setf (gethash key normalized-context-vector) (/ val magnitude))) 
               context-vector)
      (values normalized-context-vector))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Computing the associations 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-assoc-matrices (symlist &key (reasoner *reasoner*)
                                    (retrieve-refs-cache *retrieve-refs-cache*)
                                    (basic-context-vectors-cache *basic-context-vectors-cache*)
                                    (normalized-context-vectors-cache *normalized-context-vectors-cache*))
  (let* ((num (length symlist))
         (basic-assoc-matrix (make-array (list num num) :initial-element 0.0)) 
         (normalized-assoc-matrix (make-array (list num num) :initial-element 0.0)))
    ;; First compute and cache all the context vectors
    (dolist (sym symlist)
      (compute-and-cache-context-vector sym :reasoner reasoner
                                        :retrieve-refs-cache retrieve-refs-cache
                                        :basic-context-vectors-cache basic-context-vectors-cache
                                        :normalized-context-vectors-cache normalized-context-vectors-cache))
    ;; Now compute the dot products
    (dotimes (i num)
      (dotimes (j num)
        (let* ((sym1 (nth i symlist))
               (sym2 (nth j symlist))
               (basic-assoc (context-vector-dot-product (gethash sym1 basic-context-vectors-cache) 
                                                        (gethash sym2 basic-context-vectors-cache)))
               (normalized-assoc (context-vector-dot-product (gethash sym1 normalized-context-vectors-cache) 
                                                             (gethash sym2 normalized-context-vectors-cache))))
          (setf (aref basic-assoc-matrix i j) basic-assoc)
          (setf (aref normalized-assoc-matrix i j) normalized-assoc))))
    (values basic-assoc-matrix normalized-assoc-matrix)))

(defun compute-and-cache-context-vector (sym &key (reasoner *reasoner*)
                                             (retrieve-refs-cache *retrieve-refs-cache*)
                                             (basic-context-vectors-cache *basic-context-vectors-cache*)
                                             (normalized-context-vectors-cache *normalized-context-vectors-cache*))
  (let* ((basic-context-vector (compute-context-vector sym :reasoner reasoner :retrieve-refs-cache retrieve-refs-cache))
         (normalized-context-vector (safe-normalize-context-vector basic-context-vector)))
    (setf (gethash sym basic-context-vectors-cache) basic-context-vector)
    (setf (gethash sym normalized-context-vectors-cache) normalized-context-vector) 
    (values basic-context-vector normalized-context-vector)))

                               
(defun compute-assoc (sym1 sym2 &optional (reasoner *reasoner*))
  (let* ((cv1 (compute-context-vector sym1 :reasoner reasoner))
         (cv2 (compute-context-vector sym2 :reasoner reasoner))
         (basic-assoc (context-vector-dot-product cv1 cv2)) 
         (ncv1 (normalize-context-vector cv1))
         (ncv2 (normalize-context-vector cv2))
         (normalized-assoc (context-vector-dot-product ncv1 ncv2)))
    (values basic-assoc normalized-assoc)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Handling ubiquity
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun non-discriminatory-predicate? (pred)
  (or 
   (member pred *non-discriminatory-predicates*)
   (member pred *cyclists*)))
  
;; Ubiquity for computing associations is a different thing than ubiquitous-predicates
;; as in SME, which is specific to the match (the base and target case). Some of these
;; predicates which are ubiquitous-for-associations might not always be ubiquitous in 
;; the SME sense. Also, the slot ubiquitous-predicates has a list of predicate ID's which
;; are identifiers for predicate objects that SME creates during the match. 
;; NotForAnalogyPredicates are UbiquitousForAssociationPredicates, but not the converse. 
;; What are the criterion for UbiquitousForAssociationPredicates? -- 1. How frequently does

;; the predicate occur over the KB, and 2. How abstract is the predicate?
;; Should we assert this in the KB? Probably yes. 


;;;(defun install-ubiquitious-predicates-for-association-testing (source)
;;;  (with-reasoner (reasoner source)
;;;    (dolist (pred *ubiquitious-for-associations*)
;;;      (assume-ubiquitous-wm pred))
;;;    (update-ubiquitous-preds! source)))

;;; More tests
;;; A frequency histogram of all symbols in the kb. 
;;; All assertions were sucked out

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Caching for computing assoc-matrices: Since retrieving facts from the 
;;; KB takes the most time, it is a good idea to cache them. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro with-retrieve-refs-cache (retrieve-refs-cache &rest forms)
  `(let ((*retrieve-refs-cache* ,retrieve-refs-cache))
     ,@ forms))

(defun blow-all-context-caches ()  
  (setq *retrieve-refs-cache* (make-hash-table :test 'equal))
  (setq *basic-context-vectors-cache* (make-hash-table :test 'equal))
  (setq *normalized-context-vectors-cache* (make-hash-table :test 'equal)))

(defun retrieve-references-using-cache (exp &key (kb *kb*) 
                                                (context :any) 
                                                (retrieve-refs-cache *retrieve-refs-cache*))
  (multiple-value-bind (value present-p) (gethash exp retrieve-refs-cache)
    (if present-p
      value
      (let ((refs (retrieve-references exp :kb kb :context context)))
        (setf (gethash exp retrieve-refs-cache) refs)
        (values refs)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Saving/Printing Results
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun print-2d-array (arr &optional (stream t))
  (multiple-value-bind (numrows numcols)
      (array-dimensions arr)
    (dotimes (i numrows)
      (dotimes (j numcols)
        (format stream "~A " (aref arr i j)))
      (format stream "~%"))))

(defun print-2d-array-with-labels (arr rowlabels columnlabels &optional (stream t))
  (let* ((dims (array-dimensions arr))
         (numrows (car dims))
         (numcols (cadr dims)))
    (when (or (not (equal numrows (length rowlabels)))
              (not (equal numcols (length columnlabels))))
      (format t "Row/column label mismatch, Array dim = ~Ax~A, Rowlabels=~A Columnlabels=~A ~%" 
        numrows numcols (length rowlabels) (length columnlabels))
      (return-from print-2d-array-with-labels nil))
    ;; Print column labels
    (format stream " ")
    (dolist (colname columnlabels)
      (format stream " ~A" colname))
    (format stream "~%")
    ;; Print the array
    (dotimes (i numrows)
      (format stream "~A " (nth i rowlabels))
      (dotimes (j numcols)
        (format stream "~A " (aref arr i j)))
      (format stream "~%"))))

;;;(defun save-assoc-matrices (symlist basic-assoc-matrix normalized-assoc-matrix basic-assoc-file normalized-assoc-file)
;;;  (with-open-file (filestr basic-assoc-file :direction :output :if-exists :supersede)
;;;    (print-2d-array-with-labels basic-assoc-matrix symlist symlist filestr))
;;;  (with-open-file (filestr normalized-assoc-file :direction :output :if-exists :supersede)
;;;    (print-2d-array-with-labels normalized-assoc-matrix symlist symlist filestr)))

(defun save-assoc-matrix (symlist assoc-matrix filename)
  (with-open-file (filestr filename :direction :output :if-exists :supersede)
    (print-2d-array-with-labels assoc-matrix symlist symlist filestr)))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities for dumping hashtables/lists to disk
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun show-hash-table (table &optional (stream *standard-output*))
  (maphash #'(lambda (k v)
               (format stream "~A: ~A~%" k v)) table))

(defun hash-table->alist (table)
  (let ((alist nil))
    (maphash #'(lambda (k v)
                 (push (cons k v) alist)) table)
    (values alist)))

(defun dump-hash-table (table tablename fname)
  (let ((cl-user::*print-pretty* nil)) ;; Saves file space -- nil for debugging
    (with-open-file (fout fname
                          :direction :output
                          :if-does-not-exist :create
                          :if-exists :supersede)
      (format fout ";;;; -*- LISP -*- ")
      (format fout "~%(in-package :data)~%")
      (format fout
          "(setq ~S (make-hash-table :test #'~S))~%" tablename (hash-table-test table))
      (maphash #'(lambda (key val)
                   (format fout "~%(setf (gethash '~S ~S) '~S)" key tablename val)) table)
      (format fout "~%;;;;; End of File")
      fname)))

(defun dump-list (list name fname)
  (let ((cl-user::*print-pretty* nil)) ;; Saves file space -- nil for debugging
    (with-open-file (fout fname
                          :direction :output
                          :if-does-not-exist :create
                          :if-exists :supersede)
      (format fout ";;;; -*- LISP -*- ")
      (format fout "~%(in-package :data)~%")
      (format fout
          "(setq ~S '~S)~%" name list)
      (format fout "~%;;;;; End of File")
      fname)))

;;; Shakedown
#|
(defparameter *test-countries* '(data::Nepal data::Bhutan data::India data::Pakistan data::Germany))
(save-assoc-matrices *test-countries* basic normal
                     "c:\\qrg\\fire\\v1\\data\\assoc\\test-basic-country2.txt" 
                     "c:\\qrg\\fire\\v1\\data\\assoc\\test-normalized-country2.txt")


|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of code