(in-package "PENMAN")

;;; File: penman-loom-kb-interface.lisp
;;;
;;; ----------------------------------------------------------------------
;;; KPML version...
;;; 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. Loom4.0
;;; compatibility added directly.
;;;
;;; 3.2+ troublesome use of disappearing external symbols in
;;;      differing Loom versions avoided.
;;;
;;; 4.0  loom:find-concept picks up more in-built Loom concepts
;;;      that interfere nastily with the Upper Model concepts.
;;;      For some reason, after carefully selecting the right
;;;      package, most of the calls to find-concept then set the
;;;      ignore-package-p keyword. This appears wrong, so make it
;;;      instead conditional on what Loom is being used: if Loom4
;;;      we never ignore the package. This does mean, however, that
;;;      many of the KB-interface functions now explicitly force
;;;      their arguments into the defined kb-package before
;;;      looking for concepts and the like. This needs to be 
;;;      known to the inquiry implementation writer, who, I suppose,
;;;      if they used proper package specs all the time would not
;;;      have got any problems anyway.
;;;
;;;      Was not quite right yet. The don't ignore package option
;;;      in fact then prunes away too many concepts that are still
;;;      necessary, so that time and space and a few other things
;;;      then disappear. The problem is that now find-concept returns
;;;      concepts that Loom did not have before, particularly due
;;;      to its new temporal ontology. So we should definitely
;;;      have the package restriction so that we stay in the 
;;;      Upper Model. The correct solution was that one of the
;;;      concepts being checked was not properly placed into the
;;;      Upper Model package before proceeding. Fixed.
;;;
;;;      Oct03: another group of corrections are on the track of the mysterious
;;;      failure of the semantic graphing when switching to Loom4.
;;;      They are all caused by a confusion about whether KB functions
;;;      and their associated graphing functions are expecting
;;;      concepts or names of concepts. It must have been the
;;;      case that Loom4 had different behaviour or just did not
;;;      care. Now we need to do it properly and be precise; but
;;;      this will take a more careful examination of the 
;;;      information that is passed around. Also, in order to
;;;      remain compatible with Loom3, some functions are just
;;;      now extended so that they are happy with both kinds
;;;      of arguments.
;;;
;;;      Sep05: relations added as subcs (primarily for graphing)
;;;
;;; ----------------------------------------------------------------------


;;; 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,
;;; KPML 4.0 make sure everything is in the Upper Model 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... 
;;;

;;; KPML 4 
(defvar *ignore-package* #+loom4.0 nil #-loom4.0 T)

;;; 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
	   (c2 (find-symbol (symbol-name c2) (kb-package)))  ;; 4.0
           (loom-c1 (loom::find-concept 
		     c1 :ignore-package-p *ignore-package* :no-warning-p t))
	   (loom-c2 (loom::find-concept 
		     c2 :ignore-package-p *ignore-package* :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 *ignore-package* :no-warning-p t)))
          (and loom-r1
               (let ((loom-r2 
                      (loom::find-relation 
                       c2 :ignore-package-p *ignore-package* :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
	(c2 (find-symbol (symbol-name c2) (kb-package)))  ;; 4.0
	)
    (or (eq c1 c2)
        (kb-superp c1 c2))))


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

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

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

(defun KB-GETNAMEDRELATION (relation) 
  "Given a relation name, return the |R| with that name."
  (let ((relation (find-symbol (symbol-name relation) (kb-package)))  ;; 4.0
	)
    (or (loom::find-relation relation :ignore-package-p *ignore-package* :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* ((concept (if (symbolp concept)      ;; 4.0 be more careful
		      (kb-getnamedconcept    ;;     about what comes through
		       (find-symbol (symbol-name concept) (kb-package)))
		    concept))  
	 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."
  (if (loom::relation-p concept)
      (let ((?c (loom::find-relation concept)))
        (:with-conditionalized-unevaluated-args
	 loom::retrieve (- ?s) 
	 (+ `(:and (loom::relation ?s)
              ,(:version-case
                (":LOOM")
                ((- "3.0") 
                 '(loom::direct-subconcept ?c ?s))
                (t
                 '(loom::direct-subrelations ?c ?s)
                 ))))))
    (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 *ignore-package* :no-warning-p t)))
	(loom-c2 
	 (if c2 
	     (loom::find-concept c2 :ignore-package-p *ignore-package*  :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...
;;; 
;;; 4.0 indeed there is, but we use it just for Loom4.0
;;;     again there is equivocation about whether we get a name
;;;     of a concept in here or a concept itself. Make the
;;;     Loom4.0 version accept both...
;;; ----------------------------------------------------------------------

(defun KB-CONCEPT-P (c) 
  #+loom4.0(or (loom::concept-p c)
	       (loom::relation-p c)
	       (kb-getnamedconcept c))
  #-loom4.0 
  (kb-getnamedconcept c))

(defun KB-ENTITY? (instance)
  "T, if INSTANCE is known to the KB."
  (if (loom:find-instance 
       instance :ignore-package-p *ignore-package* :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 *ignore-package*
				       :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...
;;; ======================================================================
