(in-package "PENMAN")

;;; File: penman-loom-kb-interface.lisp
;;; ----------------------------------------------------------------------
;;; Based increasingly loosely on an original Penman file...
;;;
;;; Current file merges the Loom2.0, Loom2.1 and Loom3.0 file
;;; from ISI, thereby maintaining compatibility for now with 
;;; all Loom versions and adds various speedups and cleanups.
;;; Some unupdated copies of original Penman function definitions
;;; are included at the end of this file commented out.
;;;
;;; 3.2+ troublesome use of disappearing external symbols in
;;;      differing Loom versions avoided.
;;; ----------------------------------------------------------------------

;;; KPML 1.1: addition
(defvar *kr-file-extension* "loom" 
  "Contains the file extension that the resource management operations
   are to use when looking for domain model or upper model definitions")

;;; KPML 1.2
;;; (Loom 3.0 Modifications from Knut Hartmann Feb98 folded in, including: 
;;;   loom3.0 conditionalizations,
;;;   ignoring the package of concepts relations to simplify many
;;;     of the lookup functions)
;;; Some representatives of the old definitions are appended at the 
;;; bottom of the file in case they are ever needed...

;;;
;;; KPML 2.1 version conditionalization added throughout.
;;;          and kb-superp and kb=superp now insist on their first
;;;          argument being in the kb package,
;;;        because there is something strange with the treatment of domain, this
;;;        symbol is convinced somehow that it is in the Loom package,
;;;        even though it is treated exactly the same as range in all
;;;        contexts that I have found so far... range knows that it belongs
;;;        first and foremost in the penman-kb package though... 
;;;

;;; 1.2 This function was not returning a package for Loom2.1, corrected.
;;; 2.2 Version ranges added (reincorporating original)...
(defun KB-PACKAGE ()
  "Returns the package associated with LOOM:*knowledge-base*."
  (:version-case 
   (":LOOM")
   ((- "2.0") (LOOM::object-name (loom::current-context)))
   ("2.0"     (LOOM::kb-package-name LOOM::*knowledge-base*))
   ;; i.e., 2.1, 3.0, etc.
   ((+ "2.0") (find-package "PENMAN-KB"))))

;;; ----------------------------------------------------------------------
;;; Speedy version from John Wilkinson, Uni Waterloo, May 1995..
;;; Have, however, to document that kb-superp is something that
;;; can take inquiry operators as first argument and will in that
;;; case always return NIL, even though there may be identical
;;; symbols naming concepts!
;;; ----------------------------------------------------------------------

(defun KB-SUPERP (c1 c2)
  ;; first, check to see if the first concept is an inquiry name, and ignore it
  ;; if it is; as far as I know, this is valid, and screens out many calls
  (unless (gethash c1 quiry-operators)

    ;; using find-concept instead of intern because it returns nil if the name
    ;; doesn't already exist, and find-concept is relatively quick dealing with
    ;; nils.  The overhead from find-symbol accounts for about half of the total
    ;; time for this function; this could be eliminated if all concepts were
    ;; accessible from the penman package.
    (let* ((c1 (find-symbol (symbol-name c1) (kb-package)))  ;; 2.1
           (loom-c1 (loom::find-concept c1 :ignore-package-p t :no-warning-p t))
	   (loom-c2 
	    (loom::find-concept c2 :ignore-package-p t :no-warning-p t)))
      ;; only bother to check for relations if the concept check fails; also, only
      ;; find the second relation if the first exists
      (if (and loom-c1 loom-c2)
          (loom::subconcept-p loom-c1 loom-c2)
        (let ((loom-r1 
               (loom::find-relation c1 :ignore-package-p t :no-warning-p t)))
          (and loom-r1
               (let ((loom-r2 
                      (loom::find-relation 
                       c2 :ignore-package-p t :no-warning-p t)))
                 (and loom-r1 loom-r2 
                      (loom::subconcept-p loom-r1 loom-r2)))))))))

;;; ----------------------------------------------------------------------
;;; Note:
;;;  Following would be nice, but it doesn't distinguish the case where one's
;;;  a relation and not a concept & the other's both (domain participant).
;              (defun KB-superp (c1 c2)
;                 (loom::subconcept-p (KB-GetNamedConcept c1) (KB-GetNamedConcept c2)))
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; 1.2 addition...
;;; ----------------------------------------------------------------------

(defun KB=SUPERP (c1 c2)
  (let ((c1 (find-symbol (symbol-name c1) (kb-package))))  ;; 2.1
    (or (eq c1 c2)
        (kb-superp c1 c2))))


;;; ----------------------------------------------------------------------

(defun KB-GETNAMEDCONCEPT (concept) 
  "Given a concept name, return the concept with that name."
  (or 
   (loom::find-concept concept :ignore-package-p t :no-warning-p t)
   (loom::find-relation concept :ignore-package-p t :no-warning-p t)))

;;; ----------------------------------------------------------------------

(defun KB-GETNAMEDRELATION (relation) 
  "Given a relation name, return the |R| with that name."
  (or (loom::find-relation relation :ignore-package-p t :no-warning-p t)))

;;; ----------------------------------------------------------------------
;;; 3.2+ the following used external symbols in the Loom package that
;;;      cannot be guaranteed always to exist for different Loom
;;;      versions, replaced by proper references.
;;;      ------------------------------------------------------------

(defun RELATIVE-SUBCONCEPTS (concept list-of-concepts) 
  "Return subconcepts of CONCEPT which are not subconcepts of any of
   LIST-OF-CONCEPTS."
  (let (subconcepts
	(subconcept*
	 (let ((?c concept))
	   (:with-conditionalized-unevaluated-args
	       loom::retrieve 
	     (- ?s)
	     (+ `(:and (loom:concept ?s) 
		       ,(:version-case 
			 (":LOOM")
			 ((- "3.0") '(loom::subconcept* ?c ?s))
			 (t         '(loom::subrelations ?c ?s))))
		)))))
    (dolist (?sub subconcept*)
      (unless (or (eq ?sub concept)
		  (memq :system-defined (loom::attributes ?sub))
		  (dolist (?super list-of-concepts)
		    (when 
			(:with-conditionalized-unevaluated-args
			    loom:ask 
			  (+ (:version-case
			      (":LOOM")
			      ((- "3.0")  '(loom::subconcept* ?super ?sub))
			      (t          '(loom::subrelations ?super ?sub))))
			 )
		      (return t))))
	(push ?sub subconcepts)))
    subconcepts))

;;; ----------------------------------------------------------------------

(defun KB-IMMEDIATESUBCS (concept) 
  "Return the children of a concept.  Filter system-defined concepts."
  (let (subcs (immediate-subcs (subcs concept)))
    (dolist (subc immediate-subcs)
      (if (memq :system-defined (Loom::attributes subc))
	  (setq subcs (append (KB-ImmediateSubCs subc) subcs))
	  (pushnew subc subcs)))
    (loom::most-general-concepts subcs)))
  

(defun SUBCS (concept)
  "Auxilliary function to get first-round candidates for KB-ImmediateSubCs."
  (let ((?c (loom::find-concept concept)))
    (:with-conditionalized-unevaluated-args
	loom::retrieve (- ?s) 
	(+ `(:and (loom::concept ?s)
		  ,(:version-case
		    (":LOOM")
		    ((- "3.0") 
		     '(loom::direct-subconcept ?c ?s))
		    (t
		     '(loom::direct-subrelations ?c ?s)
		     )))))))

;;; ----------------------------------------------------------------------

(defun KB-IMMEDIATESUPERCS (concept) 
  "Return the parents of a concept.  Filter system-defined concepts."
  (let (supercs (immediate-supercs (supercs concept)))
    (dolist (superc immediate-supercs)
      (if (memq :system-defined (Loom::attributes superc))
	  (setq supercs (append (KB-ImmediateSupercs superc) supercs))
	  (pushnew superc supercs)))
    supercs))

;;; raw 12/91 replaced DIRECT-SUBCONCEPTS in following...
;;; jab 98 (no longer there anyway, presumably for an older Loom)...

(defun SUPERCS (concept)
  "Auxilliary function to get first-round candidates for KB-ImmediateSuperCs."
  (let ((?c (loom::find-concept concept)))
    (:with-conditionalized-unevaluated-args
	loom::retrieve 
      (- ?s)
      (+ (:version-case (":LOOM")
			((- "3.0") '(loom::direct-superconcept ?c ?s))
			(t         '(loom::direct-superrelations ?c ?s)))))))


;;; ----------------------------------------------------------------------
;;; IPSI: 12 Jan 95 (John); loom::identifier seems unreliable; replaced
;;;       call to something more primitive...
;;; Replaced by:
;;; 0.7.14 (fix from ITRI) was using out of date function for Loom 2.0.
;;; 2.1 add version ranges.
;;; 3.2+ avoid use of external symbols in the Loom package 
;;; ----------------------------------------------------------------------

(defun KB-GETCONCEPTNAME (concept) 
  "Return the name of a concept."
  (:version-case (":LOOM")
		 ((- "2.1") (loom::get-name concept))
		 (t (loom::object-name concept))))

;;; ----------------------------------------------------------------------

(defun KB-CONCEPTDISJOINT? (c1 c2)
  "True, if C1 and C2 belong to disjoint classes."
  (let ((loom-c1 
	 (if c1 
	     (loom::find-concept c1 :ignore-package-p t :no-warning-p t)))
	(loom-c2 
	 (if c2 
	     (loom::find-concept c2 :ignore-package-p t  :no-warning-p t))))
    (if (and loom-c1 loom-c2)
	(loom::disjoint-concepts-p loom-c1 loom-c2))))

;;; ----------------------------------------------------------------------
;;; KPML 2.0, added for completeness, although there's probably a
;;; proper Loom function for this...
;;; ----------------------------------------------------------------------

(defun KB-CONCEPT-P (c)
  (kb-getnamedconcept c))

(defun KB-ENTITY? (instance)
  "T, if INSTANCE is known to the KB."
  (if (loom:find-instance instance :ignore-package-p t :no-warning-p t) t))

;;; ----------------------------------------------------------------------
;;; Following extra KR-API function on the request of Knut:
;;; Return the type of ENTITY (an instance).
;;; ----------------------------------------------------------------------

(defun KB-TYPE (entity)
  (let ((instance (loom::find-instance entity :ignore-package-p t
				       :no-warning-p t)))
    (if instance
        (let ((type (loom::get-types instance)))
          (if (singleton type)
              (Loom::identifier (first type))
              (mapcar #'Loom::identifier type)))
        (if (numberp entity) 'number))))

;;; ----------------------------------------------------------------------
;;; Following is to do whatever has to be done before the KR-system
;;; is ready to work...
;;; ----------------------------------------------------------------------

(defun KB-INITIALIZATIONS ()
  (loom::tellm))

;;; ----------------------------------------------------------------------
;;; This is optional... aids inspection but does not influence 
;;; generation... (optional means that they do not need to return
;;; something sensible, but they *must* be defined if the user
;;; interface is going to work with semantic concepts)
;;; ----------------------------------------------------------------------

(defun KB-GENERATE-SOURCE-DEFINITION (concept-or-relation)
  (loom::generate-source-definition concept-or-relation))
	 
;;; Also optional...

(defun KB-SYSTEM-DEFINED-NAME-P (concept)
  (loom::system-defined-name-p concept))

;;;
;;; KPML3.0 addition... defined here for completeness...
;;; Print name here is particularly for gui-presentation.

(defun MAKE-PRINTABLE-CONCEPT-NAME (concept)
  (kb-getconceptname concept))


;;; End of KPML-LOOM interface functions.
;;; ----------------------------------------------------------------------

;;; ======================================================================
;;; Old Penman and KPML versions kept here in case more package 
;;; sensitivity is required by someone ever...
;;;
;;; NOTE: version conditionalization has not been added to these 
;;;       definitions and they remain defined only up to Loom 2.1.
;;;       If they are unmothballed, then they'd need an update.

#|| 
;;; KPML:
(defun KB-SUPERP (c1 c2)
; first, check to see if the first concept is an inquiry name, and ignore it
; if it is; as far as I know, this is valid, and screens out many calls
  (unless (gethash c1 quiry-operators)

; using find-concept instead of intern because it returns nil if the name
; doesn't already exist, and find-concept is relatively quick dealing with
; nils.  The overhead from find-symbol accounts for about half of the total
; time for this function; this could be eliminated if all concepts were
; accessible from the penman package.
   (let ((loom-c1 (or (loom::find-concept 
                        (find-symbol (symbol-name c1) "PENMAN-KB")
                                         :no-warning-p t)
                     (loom::find-concept 
                        (find-symbol (symbol-name c1) "PENMAN")
                                         :no-warning-p t)))
         (loom-c2 (or (loom::find-concept 
                        (find-symbol (symbol-name c2) "PENMAN-KB")
                                         :no-warning-p t)
                     (loom::find-concept 
                        (find-symbol (symbol-name c2) "PENMAN")
                                       :no-warning-p t))) )
; only bother to check for relations if the concept check fails; also, only
; find the second relation if the first exists
        (if (and loom-c1 loom-c2)
                (loom::subconcept-p loom-c1 loom-c2)
            (let ((loom-r1 (or (loom::find-relation
                     (find-symbol (symbol-name c1) "PENMAN-KB")
                      :no-warning-p t)
                     (loom::find-relation
                      (find-symbol (symbol-name c1) "PENMAN")
                      :no-warning-p t))))
              (and loom-r1
                (let ((loom-r2 (or (loom::find-relation
                      (find-symbol (symbol-name c2) "PENMAN-KB")
                      :no-warning-p t)
                     (loom::find-relation
                      (find-symbol (symbol-name c2) "PENMAN")
                      :no-warning-p t))))
               (and loom-r1 loom-r2 (loom::subconcept-p loom-r1 loom-r2)) ))))))
)

;;; Penman:
(defun KB-superp (c1 c2)
  (let ((loom-c1 (or (loom::find-concept (intern (symbol-name c1) (kb-package))
					 :no-warning-p t)
		     (loom::find-concept (intern (symbol-name c1) "PENMAN-KB") 
					 :no-warning-p t)))
	(loom-c2 (or (loom::find-concept (intern (symbol-name c2) (kb-package))
					 :no-warning-p t)
		     (loom::find-concept (intern (symbol-name c2) "PENMAN-KB") 
					 :no-warning-p t)))
	(loom-r1 (or (loom::find-relation
		      (intern (symbol-name c1) (kb-package)) 
		      :no-warning-p t)
		     (loom::find-relation
		      (intern (symbol-name c1) "PENMAN-KB") 
		      :no-warning-p t)))
	(loom-r2 (or (loom::find-relation
		      (intern (symbol-name c2) (kb-package)) 
		      :no-warning-p t)
		     (loom::find-relation
		      (intern (symbol-name c2) "PENMAN-KB") 
		      :no-warning-p t))))
    (or (and loom-c1 loom-c2 (loom::subconcept-p loom-c1 loom-c2))
        (and loom-r1 loom-r2 (loom::subconcept-p loom-r1 loom-r2))))) 

(defun KB-GetNamedConcept (concept) 
  "Given a concept name, return the concept with that name."
  (or (loom::find-concept 
       #-Loom2.1(intern (symbol-name concept) (kb-package)) 
       #+Loom2.1 concept
       :no-warning-p t)
      (loom::find-relation 
       #-Loom2.1(intern (symbol-name concept) (kb-package)) 
       #+Loom2.1 concept
       :no-warning-p t)
      (loom::find-concept (intern (symbol-name concept) "PENMAN") 
			  :no-warning-p t)
      (loom::find-relation (intern (symbol-name concept) "PENMAN") 
			   :no-warning-p t)
      (loom::find-concept (intern (symbol-name concept) "PENMAN-KB") 
			  :no-warning-p t)
      (loom::find-relation (intern (symbol-name concept) "PENMAN-KB") 
			   :no-warning-p t)))

(defun KB-ConceptDisjoint? (c1 c2)

  "True, if C1 and C2 belong to disjoint classes."

  (let ((loom-c1 
	  (if c1 (or (loom::find-concept c1 :no-warning-p t)
		     (loom::find-concept (intern (symbol-name c1) 
						 #-Loom2.1 (kb-package)
						 #+Loom2.1 "PENMAN")
					 :no-warning-p t)
		     (loom::find-concept (intern (symbol-name c1) "PENMAN-KB")
					 :no-warning-p t))))
	(loom-c2 
	  (if c2 (or (loom::find-concept c2 :no-warning-p T)
		     (loom::find-concept (intern (symbol-name c2) 
						 #-Loom2.1 (kb-package)
						 #+Loom2.1 "PENMAN")
					 :no-warning-p t)
		     (loom::find-concept (intern (symbol-name c2) "PENMAN-KB")
					 :no-warning-p t)))))
    (if (and loom-c1 loom-c2)(loom::disjoint-concepts-p loom-c1 loom-c2))))

||#
;;; End of old currently unused material...
;;; ======================================================================