(in-package "KPML")
;;; File: kpml-racer-interface.lisp
;;;
;;; KR-interface API written for Racer using OWL 
;;; original design: Scott Farrar: 2004-11-18
;;; modified for KPML use with correct package and
;;;  some extra utilities, JB, Dec 2004/Jan 2005.
;;;
;;; Experimental version.  Uses a new macro kr-wrap which puts
;;;  wrappers around all references to the concepts so that we do not
;;;  have to be aware of OWL syntax anywhere else in the system. 
;;;  Should make subsequent moves between versions of an 
;;;  ontology easier to manage.
;;;
;;; ----------------------------------------------------------------------


;;;Niels: Changed code to allow roles to be treated as concepts for the time being
;;; Comments for changes are annotated with RC:
;;; Generally the code from the function for concepts is repeated with function-calls to racer changed appropiately

(defvar *KR-FILE-EXTENSION* "owl"
  "Contains the file extension that the resource management operations
   are to use when looking for domain model or upper model definitions")
 
(defun KB-PACKAGE () 
  "Returns the particular Lisp package associated with the
   knowledge base."
  (find-package "CL-USER"))

 ;; ----------------------------------------------------------------------
 ;; The definitions proper...
 ;; ----------------------------------------------------------------------

;SC: same for roles
(defun KB-CONCEPT-P (c) 
  "Checks that c is defined as a concept"
  (kr-wrap (c) 
    (or (racer::concept-p c) (racer::role-p c))))
 

;; JB: looks like the comment was round the wrong way
;;     in the description of this one!!! It should be
;;     read as "is arg1 superc'd by arg2"...

;RC: same with role  
(defun KB-SUPERP (c2 c1)
  "Is c1 a superconcept of c2?"
  ;;
  ;; N.B., 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!
  ;;
  
  (unless (gethash c2 quiry-operators)
    (kr-wrap (c1 c2)
	(or
     (and (racer::concept-p c1)
	  (racer::concept-p c2)
	  (racer::concept-subsumes-p c1 c2 (racer::current-tbox)))
	 (and (racer::role-p c1)
	  (racer::role-p c2)
	  (racer::role-subsumes-p c1 c2 (racer::current-tbox)))))))

;(defun KB=SUPERP (c2 c1)
;  "Is c1 the same or a superconcept of c2?"
;  (unless (gethash c2 quiry-operators)
;    (kr-wrap (c1 c2)
;     (and (racer::concept-p c1);
;	  (racer::concept-p c2)
;	  (or 
;	   (racer::concept-equivalent-p c1 c2 (racer::current-tbox))
;	   (racer::concept-subsumes-p c1 c2 (racer::current-tbox)))))))

;racer interface provides no function to test for equivalence, as a workaround I test for mutual subsumption
;in new function
(defun KB=SUPERP (c2 c1)
  "Is c1 the same or a superconcept of c2?"
  (unless (gethash c2 quiry-operators)
    (kr-wrap (c1 c2)
     (or
	 (and 
          (racer::concept-p c1)
	  (racer::concept-p c2)
	  (or 
	   (racer::concept-equivalent-p c1 c2 (racer::current-tbox))
	   (racer::concept-subsumes-p c1 c2 (racer::current-tbox))))
	 (or
          (and
          (racer::role-p c1)
	  (racer::role-p c2)
	  (or 
	   (racer::role-equivalent-p c1 c2 (racer::current-tbox)) 
           (racer::role-subsumes-p c1 c2 (racer::current-tbox))
	   )))))))

(defun KB=SUPERP2P (c2 c1)
  "Is c1 the same or a superconcept of c2?"
  (unless (gethash c2 quiry-operators)
    (kr-wrap (c1 c2)
     (cond 
      ((and (racer::concept-p c1) (racer::concept-p c2))
       (or
        (racer::concept-equivalent-p c1 c2 (racer::current-tbox))
        (racer::concept-subsumes-p c1 c2 (racer::current-tbox)))) 
      
      ((and
        (racer::role-p c1)
	  (racer::role-p c2)) 
       (or 
        (racer::role-equivalent-p c1 c2 (racer::current-tbox)) 
        (racer::role-subsumes-p c1 c2 (racer::current-tbox))))
(T nil)))))




;separate function for roles exists, but might not be used in implementation -> extended for now
(defun KB-GetNamedConcept (c) 
  "Returns the concept with the specified name"
  (if (racer::concept-p (kr-wrapper c)) c (if (racer::role-p (kr-wrapper c)) c nil))) 

(defun KB-GetNamedRelation (r) 
  "Returns the relation with the specified name"
  (if (racer::role-p (kr-wrapper r)) r nil))   

;RC: same for roles
(defun RELATIVE-SUBCONCEPTS (concept list-of-concepts)
  "Return subconcepts of CONCEPT which are not subconcepts of any of
   LIST-OF-CONCEPTS."
  (kr-wrap (concept)
    (if (racer::concept-p concept)
	(let* ((answer ())
	       (list-o (mapcar #'kr-wrapper list-of-concepts))
	       (descendants 
		(make-atomic-list 
		 (racer::atomic-concept-descendants concept))))
	  (dolist (i descendants)
	    (if
		(null (descendant-p i list-o))
		(push (pop descendants) answer)
	      (pop descendants)
	      )
	    )
	  answer)
      (let* ((answer ())
	       (list-o (mapcar #'kr-wrapper list-of-concepts))
	       (descendants 
		(make-atomic-list 
		 (racer::role-descendants concept))))
	  (dolist (i descendants)
	    (if
		(null (descendant-p i list-o))
		(push (pop descendants) answer)
	      (pop descendants)
	      )
	    )
	  answer))))
;RC: same for roles
(defun KB-ImmediateSubCs (concept)
  "Returns the immediately dependent subconcepts of concept"
  (kr-wrap (concept)
    (if (racer::concept-p concept)
      (make-atomic-list (racer::atomic-concept-children concept))
	  (when (racer::role-p concept)(make-atomic-list (racer::role-children concept))))))

;RC: same for roles  
(defun KB-ImmediateSuperCs-old (concept)
  "Returns the immediately dominating superconcepts of concept"
  (kr-wrap (concept)
   (if (racer::concept-p concept)
     (make-atomic-list (racer::atomic-concept-parents concept))
	 (when (make-atomic-list (racer::atomic-concept-parents concept))))))


;;niels: do the same for roles 
;;; TODO removed make-atomic-list, not sure if necessary
(defun KB-ImmediateSuperCs (concept)
  "Returns the immediately dominating superconcepts of concept (or role if concept is role)"
  (kr-wrap (concept)
    (cond 
     ((racer::concept-p concept)(make-atomic-list (racer::atomic-concept-parents concept)))
     ((racer::role-p concept) (racer::atomic-role-parents concept))
    (T nil)
    )))



;;;FIXME remove if, simply return wrappered name?
;RC: same for roles
(defun KB-GetConceptName (concept)   
  "Returns the symbol naming the concept concept"
  (if (racer::concept-p (kr-wrapper concept)) concept (when (racer::role-p (kr-wrapper concept)))))    
;TODO add exception for roles 
(defun KB-ConceptDisjoint? (c1 c2)  
  "True, if C1 and C2 belong to disjoint classes."
  (kr-wrap (c1 c2)
     (and (racer::concept-p c1)
	  (racer::concept-p c2)
	  (racer::concept-disjoint-p c1 c2 (racer::current-tbox)))))

;RC: not changed  
;returns nil if instance is of type list
;might alternatively check if all members of list are indiv. 
(defun KB-entity? (instance)
  "T, if INSTANCE is known to the KB."
;;;  (racer::individual-p (kr-wrapper instance)))
;;;  (progn (print instance)(print (listp instance))(racer::individual-p (kr-wrapper instance))))
(if (listp instance) nil (racer::individual-p (kr-wrapper instance))))

;RC: not changed
(defun KB-type (instance)
  "returns the type of instance, if instance is an instance"
  ;; this function is not used anywhere in current KPML code but
  ;; could be useful if defined.
  (kr-wrap (instance)
   (if (racer::individual-instance-p instance)
       (first (first (racer::most-specific-instantiators instance))))))
  

;; ----------------------------------------------------------------------
;; JB: Maybe Racer/OWL does not need any...
;;       (Aug09: load-kbs added here)
;;
;; Some other function must start up racer and load the
;; upper model however:
;;
;;    (open-server-connection)
;;    (racer-read-file "<name of input file>")
;;
;; ----------------------------------------------------------------------

(defun KB-INITIALIZATIONS ()
  "Call this to perform any initializations the KR system needs after
   loading definitions"
  (kpml::load-kbs)
  )

;;; ----------------------------------------------------------------------
;;; Following are optional... that is,  they do not need to return
;;; something sensible, but they *must* be defined if the user
;;; interface is going to work with semantic concepts.
;;; They aid inspection but do not influence 
;;; generation... Thus, if no window interface is being used, they may be
;;; left; otherwise the window interface options for seeing these will
;;; not work. 

(defun KB-GENERATE-SOURCE-DEFINITION (object)
  "Call this to display definitions from the KPML window interface"
  "no source known")
	 
(defun KB-SYSTEM-DEFINED-NAME-P (concept)
  "If the KR system generates its own internal concepts (e.g., in a classification process) it may allow the user to interrogate this status"
  nil)


(defun MAKE-PRINTABLE-CONCEPT-NAME (concept)
  "If the KR can generate a sensible printname that is guaranteed to be presentable in a GUI, then it should be created here."
  ;; here we can simply use the KPML internal shortened
  ;; form of the concepts that we get from the kr-wrapper anyway...
  ;;
  (let ((name (or 
		  (kb-getnamedrelation concept)
		  (kb-getnamedconcept concept))))
    (if name 
	name
      "[some concept]"
      )))

;; ......................................................................
;;
;; JB: Racer just appears to return a result where the
;;     concepts are the first elements of sublists. If this
;;     is the case, simplify the above to the following--if
;;     it is not, what does then Racer return in general?

(defun make-atomic-list (x)
  (mapcar #'first x)
  )

;; N.B. this expects real OWL concepts to come through...
;;      as it is only used internally, therefore we
;;      do not wrap anything up...

;SC: is apparently only called in RELATIVE-SUBCONCEPTS
;	created second function dealing only with roles for the role-case 
(defun DESCENDANT-P (concept list-of-concepts)
  (loop for c in list-of-concepts 
	thereis (racer::concept-subsumes-p 
		 c concept (racer::current-tbox))))
		 
(defun DESCENDANT-P (concept list-of-concepts)
  (loop for c in list-of-concepts 
	thereis (racer::role-subsumes-p 
		 c concept (racer::current-tbox))))
		 

;;; -----------------------------------------------------------------------------------------------------
;;; John: Aug09 (modified from Niels' originals)
;;; These are additional functions introduced for dealing with Racer, 
;;; They may need to be considered as general KR utilities, but leave
;;; them here for the time being. All access to them is now channelled
;;; through kb-initialisations in any case. Files to be loaded are
;;; specified in global lists, normally set as command line parameters
;;; when using a KPML-Racer server.... 

;;; Set up to load/compile safely regardless of whether we are in a
;;; generation server or not... so make sure the following are bound
;;; at least... An additional function added below that loads the
;;; hardcoded paths....
;;;
(defvar *use-racer* T)
(defvar *racer-port* nil)
(defvar *mirrorlist* nil)
(defvar *ontolist* nil)
(defvar *annotationlist* nil)

(defun LOAD-KBS ()
  (format t "~%;;; Attempting connection to Racer server ...")
  (cond ((numberp *racer-port*)
	 (racer::connect-to-server *racer-port*)
	 (format t " [port ~S]" *racer-port*))
	(t
	 (racer::default-connect-to-server)))

  (cond
   (*ontolist* 
    ;; JB: do mirror list... this seems to want to go in pairs, currently
    ;;       only one pair being used, typically:
    ;;       ("http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl" "file://gum-3.owl")
    ;;       but attempt to do properly in any case....
    (mirror-ontologies *mirrorlist*)

    ;; (racer::mirror "http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl" "file://gum-3.owl")
    ;; (racer::service-request "(owl-read-file \"gum-3-space.owl\" :KB-NAME KB)")
    ;; (racer::service-request "(owl-read-file \"uio.owl\" :KB-NAME KB :init nil)")

    ;; JB: load ontologies as set in any command line parameters to
    ;;       a KPML-Racer server... 
    (load-ontologies *ontolist*)

    (loop for f in *annotationlist*
	  do
	  (format t "~%;;; Racer init: annotations ~S" f)
	  (load 
	   (merge-pathnames f *root-of-resources*)))

    (set-penman-feature :semantics :|GUM3 + GUM3-space + UIO [OWL]|)
    )

   (t
    (hard-load-kbs))))

;;; for debugging...

(defun HARD-LOAD-KBS ()
  (when cl-user::*upper-model-required?*
    (racer:mirror
     "http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl" "file://gum-3.owl")
    (racer::service-request "(owl-read-file \"gum-3-space.owl\" :KB-NAME KB)")
    (racer::service-request "(owl-read-file \"uio.owl\" :KB-NAME KB :init nil)")
    (set-penman-feature :semantics :|Hard: GUM3 + GUM3-space + UIO [OWL]|)
  ))

;;; ----------------------------------------------------------------------
;;; JB: Additional ontology loading functions cleaned up ....
;;; 

(defun LOAD-ONTOLOGY (ontoname &key (init nil))
  (let ((val (concatenate 
	      'string 
	      "(owl-read-file \"" ontoname "\" :KB-NAME KB "
	      (if init ":init T" ":init nil")
	      ")"))) 
    (format t  "~%;;; Racer OWL request : ~S" val)
    (racer::service-request val) 
    ))

(defun LOAD-ONTOLOGIES (list)
  (when list
    (load-ontology (first list) :init T)
    (loop for ontology in (cdr list)
	  do (load-ontology ontology :init nil))))

(defun MIRROR-ONTOLOGIES (ontolist)
  (loop for (o1 o2) on ontolist by #'cddr 
	do 
	(format t  "~%;;; Racer mirroring: ~S -> ~S" o1 o2)
	(apply #'racer::mirror (list o1 o2))))


