;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: scache-defs.lsp
;;;;    System: 
;;;;    Author: Ken Forbus
;;;;   Created: December 17, 2003 08:35:29
;;;;   Purpose: Provide rapid retrieval of structural information
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Tuesday, June 1, 2004 at 01:00:11 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

(defclass sc-entry ()
  ((sc-item :type t :initarg :sc-item :reader sc-item
         :documentation "The thing that this entry is about.")
   (sc-id :type integer :initarg :sc-id :reader sc-id
          :documentation "Integer ID for sort algorithms")
   (sc-type :type symbol :initarg :sc-type :initform :constant :accessor sc-type
            :documentation 
            "One of :constant, :predicate, :collection, :relation, :function, or :microtheory")
   (sc-details :type t :initform :unknown :accessor sc-details
            :documentation "Typed object containing information pertient to that type")
   (sc-isas :type t :initform nil :accessor sc-isas
         :documentation "Collections that this is an instance of.")
   (sc-context-vector :type t :initform nil :accessor sc-context-vector
                      :documentation "Context vector for this item")
   (sc-marker :type t :initform nil :accessor sc-marker
               :documentation "Slot for temporary markers for propagation algorithms")))

(defmethod print-object ((thing sc-entry) stream)
  (format stream "<SC:~A,~A (~D)>" 
    (sc-item thing) (sc-type-code (sc-type thing)) (sc-id thing)))

(defun sc-type-code (type)
  (case type
    (:constant "i")
    (:relation "r")
    (:collection "c")
    (:function "f")
    (:predicate "p")
    (:logical "l")
    (:microtheory "m")
    (t "??")))

;; The details objects have to be distinct because there are very different slots
;; and operations that make sense for predicates versus collections.  

(defclass sc-details ()
  ((sc-entry :type sc-entry :initarg :sc-entry :reader sc-entry
          :documentation "Backpointer to the sc-entry it details.")))

(defclass sc-collection-details (sc-details)
  ((sc-genls :type t :initform nil :initarg :sc-genls :accessor sc-genls
          :documentation "genls for this collection.")
   (sc-specs :type t :initform nil :initarg :sc-specs :accessor sc-specs
          :documentation "specs for this collection")
   (sc-all-genls :type t :initform nil :initarg :sc-all-genls :accessor sc-all-genls
          :documentation "allGenls for this collection.")
   (sc-all-specs :type t :initform nil :initarg :sc-all-specs :accessor sc-all-specs
                 :documentation "allSpecs for this collection")
   (sc-n-instances :type integer :initform 0 :initarg :sc-n-instances
                   :accessor sc-n-instances
                   :documentation "Number of instances explicitly known in this collection.")
   (sc-disjoints :type t :initform nil :accessor sc-disjoints
                 :documentation "Set of collections known to be disjoint with this one.")))

;; KDF: Is it worth indexing instances here, too? 
;; No, because these would get HUGE, and blow out memory.  I've tried it. 

(defmethod print-object ((thing sc-collection-details) stream)
  (format stream "<Details C:~A>" (sc-item (sc-entry thing))))

(defclass sc-predicate-details (sc-details)
  ((sc-genlpreds :type t :initform nil :initarg :sc-genlpreds :accessor sc-genlpreds
              :documentation "genlPreds for this predicate.")
   (sc-specpreds :type t :initform nil :initarg :sc-specpreds :accessor sc-specpreds
              :documentation "genlPreds for this predicate.")
   (sc-arg-isas :type t :initform nil :initarg :sc-arg-isas :accessor sc-arg-isas
             :documentation "Alist of (<nth arg> . <list of collections>) for argIsa constraints")
   (sc-n-ary? :type t :initform nil :initarg :sc-n-ary? :accessor sc-n-ary?
           :documentation "If true, then the predicate is n-ary.  Otherwise see arity.")
   (sc-arity :type t :initform :unknown :initarg :sc-arity :accessor sc-arity
             :documentation "Arity of predicate.")
   (sc-commutative? :type t :initform nil :initarg :sc-commutative? :accessor sc-commutative?
                    :documentation "Commutative predicate?")
   (sc-result-isa :type t :initform :unknown :initarg :sc-result-isa :accessor sc-result-isa
                  :documentation "resultIsa information")
   (sc-role-relation-pos :type t :initform nil :initarg :sc-role-relation-pos
                         :accessor sc-role-relation-pos
                         :documentation "Argument corresponding to reified event, if any.")
   )) ;; N.B. Surprisingly, Cyc does define resultIsa for relations as well as functions.


(defmethod print-object ((thing sc-predicate-details) stream)
  (format stream "<Details P:~A>" (sc-item (sc-entry thing))))

(defclass sc-relation-details (sc-predicate-details) ())

(defmethod print-object ((thing sc-relation-details) stream)
  (format stream "<Details R:~A>" (sc-item (sc-entry thing))))

(defclass sc-function-details (sc-predicate-details) 
  ((sc-lisp-handler :type t :initform nil :initarg :sc-lisp-handler
                    :accessor sc-lisp-handler
                    :documentation "Lisp handler for evaluation, if any.")))

(defmethod print-object ((thing sc-function-details) stream)
  (format stream "<Details F:~A>" (sc-item (sc-entry thing))))

(defclass sc-logical-details (sc-predicate-details) ())

(defmethod print-object ((thing sc-logical-details) stream)
  (format stream "<Details L:~A>" (sc-item (sc-entry thing))))

(defclass sc-microtheory-details (sc-details)
  ((sc-genlmts :type t :initform nil :initarg :sc-genlmts :accessor sc-genlmts
              :documentation "genlMts for this microtheory")
   (sc-specmts :type t :initform nil :initarg :sc-specmts :accessor sc-specmts
               :documentation "specMts for this microtheory")
   (sc-n-facts :type integer :initform 0 :initarg :sc-n-facts :accessor sc-n-facts
            :documentation "number of facts for this microtheory")))

(defmethod print-object ((thing sc-microtheory-details) stream)
  (format stream "<Details Mt:~A>" (sc-item (sc-entry thing))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Quick type checks

(defmethod sc-entry? ((thing t)) nil)
(defmethod sc-entry? ((thing sc-entry)) t)

(defmethod sc-collection? ((thing t)) nil)
(defmethod sc-collection? ((thing sc-entry))
  (typep (sc-details thing) 'sc-collection-details))

(defmethod sc-function? ((thing t)) nil)
(defmethod sc-function? ((thing sc-entry)) 
  (typep (sc-details thing) 'sc-function-details))

(defmethod sc-relation? ((thing t)) nil)
(defmethod sc-relation? ((thing sc-entry))
  (typep (sc-details thing) 'sc-relation-details))

(defmethod sc-logical? ((thing t)) nil)
(defmethod sc-logical? ((thing sc-entry))
  (typep (sc-details thing) 'sc-logical-details))

(defmethod sc-predicate? ((thing t)) nil)
(defmethod sc-predicate? ((thing sc-entry))
  (typep (sc-details thing) 'sc-predicate-details))

;; This is to detect when it is the more vague version
(defmethod sc-predicate-only? ((thing sc-entry))
  (let ((details (sc-details thing)))
    (and (typep details 'sc-predicate-details)
         (not (typep details 'sc-relation-details))
         (not (typep details 'sc-function-details))
         (not (typep details 'sc-logical-details)))))

(defmethod sc-predicate-details? ((thing t)) nil)
(defmethod sc-predicate-details? ((thing sc-predicate-details)) t)

(defmethod sc-function-details? ((thing t)) nil)
(defmethod sc-function-details? ((thing sc-function-details)) t)

(defmethod sc-constant? ((thing t)) nil)
(defmethod sc-constant? ((thing sc-entry)) (eq (sc-type thing) :constant))

(defmethod sc-microtheory? ((thing t)) nil)
(defmethod sc-microtheory? ((thing sc-entry)) (eq (sc-type thing) :microtheory))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ArgIsa constraints

(defun add-argisa-constraint (predicate n col)
  ;; Arguments have already been reality-checked.
  (let* ((details (sc-details predicate))
         (entry (assoc n (sc-arg-isas details) :test '=)))
    (cond (entry ;; Avoid redundancy
           (pushnew col (cdr entry)))
          (t (setq entry (cons n nil))
             (setf (sc-arg-isas details)
               (merge 'list (list entry) (sc-arg-isas details)
                      #'(lambda (x y) (< (car x) (car y)))))
             (push col (cdr entry))))))
      
(defun remove-argisa-constraint (predicate n col)
  (let ((entry (assoc n (sc-arg-isas (sc-details predicate)) :test '=)))
    (cond (entry 
           (setf (cdr entry) (delete col (cdr entry)))))))
          

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Constructors

(defun find-or-make-sc-entry (name kb)
  (let* ((cache (structural-cache kb))
         (entry (gethash name (table cache))))
    (cond ((sc-entry? entry) entry)
          ;; Everything is an entity, after all.
          ;; But with this constructor, we don't know what type of
          ;; entity, hence we leave the details out.
          (t (setq entry (make-instance 'sc-entry :sc-item name
                           :sc-id (get-current-sc-entry-id cache)))
             (setf (gethash name (table cache)) entry)
             entry))))

(defun find-or-make-sc-collection (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-collection? 'sc-collection-details :collection))

(defun find-or-make-sc-relation (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-relation? 'sc-relation-details :relation))

(defun find-or-make-sc-function (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-function? 'sc-function-details :function))

(defun find-or-make-sc-logical (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-logical? 'sc-logical-details :logical))

(defun find-or-make-sc-predicate (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-predicate? 'sc-predicate-details :predicate))

(defun find-or-make-sc-microtheory (name kb)
  (find-or-make-sc-detailed name kb
                            'sc-microtheory? 'sc-microtheory-details :microtheory))

(defun find-or-make-sc-detailed (name kb test details-type type)
  (let* ((cache (structural-cache kb))
         (entry (gethash name (table cache))))
    (cond ((sc-entry? entry)
           (cond ((funcall test entry) entry)
                 ((eq (sc-type entry) :constant)
                  ;; Started out vague, so we coerce it
                  (setf (sc-details entry) 
                    (make-instance details-type
                      :sc-entry entry))
                  (setf (sc-type entry) type)
                  entry)
                 ((eq (sc-type entry) :predicate)
                  ;; Can only get to here if it is something more
                  ;; specific than predicate, so we need to coerce.
                  (setf (sc-details entry) (coerce-predicate-details
                                            entry (sc-details entry) details-type))
                  (setf (sc-type entry) type)
                  entry)
                 (t (error "~A cannot be ~A, already is ~A in ~A: ~A"
                      name type (sc-type entry) (name kb) entry))))
          (t (setq entry (make-instance 'sc-entry :sc-item name
                           :sc-id (get-current-sc-entry-id cache)))
             (setf (sc-details entry) (make-instance details-type
                                        :sc-entry entry))
             (setf (sc-type entry) type)
             (setf (gethash name (table cache)) entry)
             entry)))) 

(defun coerce-predicate-details (entry current-details new-type)
  (cond ((sc-predicate-details? current-details)
         (make-instance new-type :sc-entry entry
           :sc-genlpreds (sc-genlpreds current-details)
           :sc-specpreds (sc-specpreds current-details)
           :sc-arg-isas (sc-arg-isas current-details)
           :sc-arity (sc-arity current-details)
           :sc-n-ary? (sc-n-ary? current-details)
           :sc-commutative? (sc-commutative? current-details)
           :sc-result-isa (sc-result-isa current-details)
           :sc-role-relation-pos (sc-role-relation-pos current-details)))
        (t (make-instance new-type :sc-entry entry))))

(defun find-or-make-predicate-details (entry)
  (cond ((sc-details entry) (sc-details entry))
        (t (setf (sc-details entry)
             (make-instance 'sc-predicate-details :sc-entry entry))
           (sc-details entry))))

(defun coerce-predicate-to-relation (entry) 
  (setf (sc-details entry) 
    (coerce-predicate-details entry (sc-details entry)
                              'sc-relation-details))
  (setf (sc-type entry) :relation)
  entry)

(defun coerce-predicate-to-function (entry) 
  (setf (sc-details entry) 
    (coerce-predicate-details entry (sc-details entry)
                              'sc-function-details))
  (setf (sc-type entry) :function)
  entry)

(defun coerce-predicate-to-logical (entry) 
  (setf (sc-details entry)
    (coerce-predicate-details entry (sc-details entry)
                              'sc-logical-details))
  (setf (sc-type entry) :logical)
  entry)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Retrievers
;;
;; These are used in contexts where the type is already known.
;; If it isn't there, that constitutes an error.

(defmethod find-sc-entry ((name t) (kb knowledge-base))
  (let* ((cache (structural-cache kb))
         (entry (gethash name (table cache))))
    (if (sc-entry? entry) entry nil)))

(defmethod find-sc-collection ((name t) (kb knowledge-base))
  (let* ((cache (structural-cache kb))
         (entry (gethash name (table cache))))
    (if (sc-collection? entry) entry nil)))

(defmethod find-sc-predicate ((name t) (kb knowledge-base))
    (let* ((cache (structural-cache kb))
           (entry (gethash name (table cache))))
      (if (sc-predicate? entry) entry nil)))

(defmethod find-sc-function ((name t) (kb knowledge-base))
    (let* ((cache (structural-cache kb))
           (entry (gethash name (table cache))))
      (if (sc-function? entry) entry nil)))

(defmethod find-sc-relation ((name t) (kb knowledge-base))
    (let* ((cache (structural-cache kb))
           (entry (gethash name (table cache))))
      (if (sc-relation? entry) entry nil)))

(defmethod find-sc-microtheory ((name t) (kb knowledge-base))
  (let* ((cache (structural-cache kb))
         (entry (gethash name (table cache))))
    (if (sc-microtheory? entry) entry nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Terse displays

(defun show-sc-entry (entry &optional (stream *standard-output*))
  (format stream "~&~A(~A):~%" (sc-item entry) (sc-type-code (sc-type entry)))
  (format stream "~&  isa: ~A~%" (mapcar 'sc-item (sc-isas entry)))
  (show-sc-entry-details (sc-details entry) stream))

(defmethod show-sc-entry-details ((details t) (stream t)))

(defmethod show-sc-entry-details ((details sc-collection-details) (stream t))
  (format stream "~&  genls: ~A" (sc-genls details))
  (format stream "~%  specs: ~A" (sc-specs details))
  (format stream "~%  allgenls: ~A" (sc-all-genls details))
  (format stream "~%  allspecs: ~A" (sc-all-specs details))
  (format stream "~%  # instances: ~D" (sc-n-instances details)))

(defmethod show-sc-entry-details ((details sc-predicate-details) (stream t))
  (show-predicate-details details stream))

(defun show-predicate-details (details stream)
  (format stream "~&  genlPreds: ~A~%" (sc-genlpreds details))
  (format stream "~&  specPreds: ~A~%" (sc-specpreds details))
  (format stream "~&  argIsas: ~A~%" (sanitize-sc-entry-alist (sc-arg-isas details)))
  (if (sc-n-ary? details) (format stream "~&  N-ary: true")
    (format stream "~&   Arity: ~D~%" (sc-arity details)))
  (format stream "~&  Commutative: ~A~%" 
    (if (sc-commutative? details) "Yes" "No"))
  (format stream "~&  resultIsa: ~A~%" (sanitize-sc-entry-list (sc-result-isa details)))
  (if (sc-role-relation-pos details)
    (format stream "~&  Reified event is argument ~D." (sc-role-relation-pos details))))  

(defun show-function-details (details stream)
  (show-predicate-details details stream)
  (if (sc-lisp-handler details)
    (format stream "~&  Lisp handler: ~A~%" (sc-lisp-handler details))
    (format stream "~%  No lisp handler.")))

(defmethod show-sc-entry-details ((details sc-relation-details) (stream t))
  (show-predicate-details details stream))

(defmethod show-sc-entry-details ((details sc-function-details) (stream t))
  (show-predicate-details details stream)
  (format stream "~&  resultIsas: ~A~%" 
    (sanitize-sc-entry-list (sc-result-isa details))))

(defmethod show-sc-entry-details ((details sc-logical-details) (stream t))
  (show-predicate-details details stream))

(defmethod show-sc-microtheory-details ((details sc-microtheory-details) (stream t))
  (format stream "~&  # facts: ~D~%" (sc-n-facts details))
  (format stream "~&  genlMts: ~A~%" (sc-genlmts details))
  (format stream "~&  specMts: ~A~%" (sc-specmts details)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Accessors

;; True, anyone writing something that uses the structural cache better
;; be pretty familiar with the details.  But let's make our lives easier.

(defmethod sc-collection-specs ((col t)) nil)
(defmethod sc-collection-specs ((col sc-entry))
  (when (sc-collection? col)
    (sc-specs (sc-details col))))

(defmethod sc-collection-genls ((col t)) nil)
(defmethod sc-collection-genls ((col sc-entry))
  (when (sc-collection? col)
    (sc-genls (sc-details col))))

(defmethod sc-collection-n-instances ((col t)) 0)
(defmethod sc-collection-n-instances ((col sc-entry))
  (if (sc-collection? col)
    (sc-n-instances (sc-details col)) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Structural cache itself

(defclass structural-cache ()
  ((table :type t :initform (make-hash-table :test 'equal
                                             :size 1000
                                             :rehash-threshold 0.9
                                             :rehash-size 100)
          :initarg :table
          :accessor table :documentation "Table for structural cache entries.")
   (kb :type knowledge-base :initarg :kb :reader kb
       :documentation "The KB that this cache is for.")
   (updated? :type t :initform nil :accessor updated?
             :documentation
             "Indicates that updates have occurred, and needs to be dumped when DB closed.")
   (id-counter :type integer :initform -1 :accessor id-counter
               :documentation "Counter for sc-entry id's")
   (sc-current-marker :type t :initform 0 :accessor sc-current-marker
                      :documentation "Tracking markers for propagation algorithms.")))

(defmethod structural-cache? ((thing t)) nil)
(defmethod structural-cache? ((thing structural-cache)) t)

(defun make-structural-cache (kb &optional (table (make-hash-table :test 'equal))) 
  (setf (structural-cache kb) (make-instance 'structural-cache
                                :kb kb :table table)))

(defun clear-structural-cache (kb)
  (cond ((structural-cache? (structural-cache kb))
         (clrhash (table (structural-cache kb))))
        (t (make-structural-cache kb))))

(defun get-current-sc-entry-id (cache) (incf (id-counter cache)))

;; Markers
;; Right now markers are implemented as integers.  Odds are, we won't be using them
;; enough to worry about rollover or bignums.  Markers aren't dumped, so each instance
;; of the cache object starts from scratch.

(defun generate-new-structural-cache-marker (cache) (incf (sc-current-marker cache)))

(defun current-structural-cache-marker (cache) (sc-current-marker cache))

(defun same-marker? (a b) (and (integerp a) (integerp b) (= a b)))

(defun map-over-sc-entries (procedure cache)
  (maphash #'(lambda (key value)
               (declare (ignore key))
               (funcall procedure value))
           (table cache)))

(defun id->sc (id &key (kb *kb*))
  (map-over-sc-entries #'(lambda (sc-entry)
                           (when (= id (sc-id sc-entry))
                             (return-from id->sc (values sc-entry))))
                       (structural-cache kb)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; More detailed stats

(defun microtheory-statistics (&key (kb *kb*)
                                    (stream *standard-output*))
  (let ((min-genls 1000000)
        (min-specs 1000000)
        (min-facts 1000000)
        (max-genls -1)
        (max-specs -1)
        (max-facts -1)
        (total-specs 0)
        (total-genls 0)
        (total-facts 0)
        (total-mts 0))
    (map-over-sc-entries 
     #'(lambda (sc-entry)
         (when (sc-microtheory? sc-entry)
           (incf total-mts)
           (let* ((details (sc-details sc-entry))
                  (len (length (sc-genlmts details))))
             (if (< len min-genls) (setq min-genls len))
             (if (> len max-genls) (setq max-genls len))
             (incf total-genls len)
             (setq len (length (sc-specmts details)))
             (if (< len min-specs) (setq min-specs len))
             (if (> len max-specs) (setq max-specs len))
             (incf total-specs len)
             (if (< (sc-n-facts details) min-facts) (setq min-facts (sc-n-facts details)))
             (if (> (sc-n-facts details) max-facts) (setq max-facts (sc-n-facts details)))
             (incf total-facts (sc-n-facts details)))))
     (structural-cache kb))
    (format stream "~%~D microtheories in ~A." total-mts (name kb))
    (format stream "~&# genlMts: ~D min, ~D max, ~D average."
      min-genls max-genls (/ (float total-genls) total-mts))    
    (format stream "~&# specMts: ~D min, ~D max, ~D average."
      min-specs max-specs (/ (float total-specs) total-mts))
    (format stream "~&~D facts: ~D min, ~D max, ~D average."
      total-facts min-facts max-facts (/ (float total-facts) total-mts))
    kb)) 
   

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