(in-package "KPML")

 ;; John, Bremen, Jan 2005
 ;;
 ;; Wrapper for using OWL... Only the wrapping functions themselves are
 ;; OWL specific.
 ;;
 ;; Avoid the necessity of redefining all concepts used internally in KPML
 ;; with their OWL forms.
 ;;
 ;; The biggest pain here is the different naming conventions. This
 ;; wrapper tries to avoid us having to make any changes to the 
 ;; source inquiry implementation files until we have a complete list
 ;; of correspondences that can be run off as a global edit.

;(defvar *KR-BASE-STRING*  "http://www.ontospace.uni-bremen.de/um89.owl#")
(defvar *KR-BASE-STRING*  "http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl#")
(defvar *trace-kr-mappings* NIL)

;defines the mapping from short prefixes to long prefixes
(defparameter *PREFIXES* 
'(	
  ("gum"   "http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl")
  ("space"   "http://www.ontospace.uni-bremen.de/ontology/GUM-3-space.owl")
  ("uio" "http://www.diaspace.uni-bremen.de/UIO.owl")
))

(defun reverse-tupel (tup)(list (second tup) (first tup)))

(defvar *REV-PREFIXES* (mapcar #'(lambda (x) (reverse-tupel x)) *prefixes*))




 (defun test-readtable-case-reading ()
   (let ((*readtable* (copy-readtable nil)))
     (format t "READTABLE-CASE  Input   Symbol-name~
              ~%-----------------------------------~
              ~%")
     (dolist (readtable-case '(:upcase :downcase :preserve :invert))
       (setf (readtable-case *readtable*) readtable-case)
       (dolist (input '("ZEBRA" "Zebra" "zebra"))
         (format t "~&:~A~16T~A~24T~A"
                 (string-upcase readtable-case)
                 input
                 (symbol-name (read-from-string input)))))))


(defparameter *DEFAULT-SHORT-PREFIX* "gum#")

(defparameter *DEFAULT-PREFIX* "http://www.ontospace.uni-bremen.de/ontology/GUM-3.owl#")



;encapsulates access to prefix mapping structure, returns nil if no prefix is found

;(defun find-prefix (mini-prefix mapping)(cadr(assoc (string-downcase mini-prefix) mapping :test #'string=)))

(defun find-prefix (mini-prefix mapping)(cadr(assoc  mini-prefix mapping :test #'string=)))

;removes short prefix from given name and adds long prefix. Adds default long prefix if no prefix is found.

(defun add-prefix (name mapping use-std-prf?)(progn 
                          (setf sep (position #\# name))
                          (if sep (progn
                                    (setf prefix (subseq name 0 sep))
                                    (setf suffix (subseq name (+ 1 sep) (length name)))
                                    (setf new-prefix (find-prefix prefix mapping))
                                    (if new-prefix (concatenate 'string new-prefix "#" suffix) 
                                      (progn (warn (concatenate 'string "Unknown prefix: " prefix) (print name) )
                                        suffix)))
                            (if use-std-prf? (concatenate 'string *DEFAULT-PREFIX* name) name))
                          ))


(defun has-prefix (name)
;return true if name contains #
(if (position #\# (symbol-name name)) T nil))

(defun add-standard-prefix (name) (intern (concatenate 'string *DEFAULT-SHORT-PREFIX* (symbol-name name))))


(defun kr-wrapper (in)
  (if (or (string= (string-downcase in) "*top*") (string= (string-downcase in) "top")) in
  (intern 
   (add-prefix (symbol-name in) *prefixes* T) (kb-package))))


(defun old-KR-WRAPPER (simple-name)
  (if (listp simple-name) nil 
    (if (or (string-equal "TOP" (symbol-name simple-name))(string-equal "*TOP*" (symbol-name simple-name))) simple-name
      (progn
        (setf temp simple-name)
        (setf ret1 (sub-wrapper-1 simple-name))
        (if(racer::concept-p ret1) ret1 (sub-wrapper-2 temp))))))

(defun SUB-WRAPPER-1 (simple-name)
  (let* ((simple-name (LISP-UM89-to-OWL-UM89 simple-name))
         (simple-name (nstring-upcase (string simple-name) :start 0 :end 1))
	 (symbol 
	  (intern 
	   (add-prefix (string simple-name))
	   (kb-package))))
           
    (when *trace-kr-mappings*
      (if (racer::concept-p symbol)
	  (setf (gethash simple-name *um-concepts-old2new*) symbol)
	(setf (gethash simple-name *um-concepts-old2new-fail*) symbol)))
    symbol))

(defun SUB-WRAPPER-2 (simple-name)
  (let* ((simple-name (LISP-UM89-to-OWL-UM89 simple-name))
			(simple-name (nstring-downcase (string simple-name) :start 0 :end 1))
	 (symbol 
	  (intern 
	   (add-prefix (string simple-name))
	   (kb-package))))

    (when *trace-kr-mappings*
      (if (racer::racer-concept-p symbol)
	  (setf (gethash simple-name *um-concepts-old2new*) symbol)
	(setf (gethash simple-name *um-concepts-old2new-fail*) symbol)))
    
    symbol))

;
(defun old-SUB-WRAPPER-1 (simple-name)
  (let* ((simple-name (LISP-UM89-to-OWL-UM89 simple-name))
         (simple-name (nstring-upcase (string simple-name) :start 0 :end 1))
	 (symbol 
	  (intern 
	   (concatenate 'string
			*kr-base-string*
			(string simple-name))
	   (kb-package))))
           
           
    (when *trace-kr-mappings*
      (if (racer::concept-p symbol)
	  (setf (gethash simple-name *um-concepts-old2new*) symbol)
	(setf (gethash simple-name *um-concepts-old2new-fail*) symbol)))
    symbol))

(defun old-SUB-WRAPPER-2 (simple-name)
  (let* ((simple-name (LISP-UM89-to-OWL-UM89 simple-name))
			(simple-name (nstring-downcase (string simple-name) :start 0 :end 1))
	 (symbol 
	  (intern 
	   (concatenate 'string
			*kr-base-string*
			(string simple-name))
	   (kb-package))))

    (when *trace-kr-mappings*
      (if (racer-concept-p symbol)
	  (setf (gethash simple-name *um-concepts-old2new*) symbol)
	(setf (gethash simple-name *um-concepts-old2new-fail*) symbol)))
    
    symbol))	
(defun OLD-KR-WRAPPER (simple-name)
  (let* ((simple-name (LISP-UM89-to-OWL-UM89 simple-name))
	 (symbol 
	  (intern 
	   (concatenate 'string
			*kr-base-string*
			(string simple-name))
	   (kb-package))))

    (when *trace-kr-mappings*
      (if (racer-concept-p symbol)
	  (setf (gethash simple-name *um-concepts-old2new*) symbol)
	  (setf (gethash simple-name *um-concepts-old2new-fail*) symbol)))
    
    symbol))


;; Unwrapper needs to be slightly prescient in order to guess what the
;; original upper model concept was. For now, we turn back string-internal
;; upper case characters to be preceded by hyphens... The following
;; hacked version works well for the UM89 naming conventions,
;; but for others might not be much good. 
;;
;; The existence of a few acronyms, like RST, mess things up well
;; however.

(defun old-KR-UNWRAPPER (c)
  (let* ((string-name (string c))
	 (pos (position #\# string-name)))
    (if pos
	(let* ((seq0
		(uncap-rst
		 (subseq string-name (1+ pos)(length (string string-name)))))
	       (exception (check-for-exceptions-reverse seq0))
	       (seq 
		(if exception (string exception)
		  seq0)))
	  (intern
	   (string-upcase
	    (coerce 
	     (cons (char seq 0)
		   (loop for i from 1 to (1- (length seq)) 
			 if (upper-case-p (char seq i))
			 collect #\- and collect (char seq i)
			 else collect (char seq i)))
	     'string))
	   (find-package "KPML")))
      c)))
  
(defun KR-UNWRAPPER (in)
  (intern 
   (add-prefix (symbol-name in) *rev-prefixes* nil) (kb-package)))


;;
;; The following hack is intended to help us out with the
;; different naming conventions... sigh ...
;;

(defvar *um-concepts-old2new* (make-hash-table :test #'equal))
(defvar *um-concepts-old2new-fail* (make-hash-table :test #'equal))

(defun CLUM () 
  (clrhash *um-concepts-old2new*)
  (clrhash *um-concepts-old2new-fail*))

(defun LISP-UM89-to-OWL-UM89 (name)
  (let* ((string-u (string-upcase name))
	 (string-d (string-downcase string-u)))
    (check-for-exceptions
     (intern
      (cap-rst
       (coerce 
	(cons
	 (char string-u 0)
	 (loop for i from 1 to (1- (length string-u))
	       if (char= (char string-u i) #\-)
	       collect 
	       (prog1 
		   (char string-u (1+ i))
		 (setf i (1+ i)))
	       else 
	       collect (char string-d i)))
	'string))
      (find-package "KPML")))))

(defun CAP-RST (string)
  (let ((pos (search "Rst" string)))
    (if pos
	(replace string "RST" :start1 pos)
      string)))

(defun UNCAP-RST (string)
  (let ((pos (search "RST" string)))
    (if pos
	(replace string "rst" :start1 pos)
      string)))

(defun REPAIR-- (string)
  (let ((pos (search "--" string)))
    (if pos
	(replace string "-" :start1 pos :end1 (1+ pos))
      string)))


(defparameter *exceptions* 
  '((|TemporalNonordering|      |TemporalNonOrdering|)
    (|NondecomposableObject|    |NonDecomposableObject|)

    ;;
    ;; these must be added to the OWL file. Wing it for now...
    ;;
    (|GenericPerson|            |ConsciousBeing|)
    (|GeneralizedPossessionInverse| |GeneralizedPossession|)
    (|RelativeDay|              |RelativeSpatialTemporal|)
    (|NamedObject|              |Object|)
    (|NonDirectedHappening|     |NonDirectedAction|)
    (|NondirectedHappening|     |NonDirectedAction|)
    (|NondirectedDoing|         |NonDirectedAction|)
    (|PosteriorExtremal|        |Posterior|)
    (|PartOf|                   |ElementOf|)
    (|UmSet|                    |UMSet|)
    (|Relational|               |RelationalProcess|)
    ))


(defun CHECK-FOR-EXCEPTIONS (string)
  (let ((n (assoc string *exceptions*)))
    (if n (cadr n)
      string)))

(defun CHECK-FOR-EXCEPTIONS-REVERSE (string)
  (let ((n (find string (reverse *exceptions*)
		 :key #'cadr 
		 :test #'(lambda (x y) 
			   (equal x (string y))))))
    (if n (car n)
      nil)))


;; Concepts and roles from the upper model are used in inquiry
;; implementations. They are generally used without any explicit
;; indication, that is they are simple (usually) quoted symbols
;; mentioning the concepts/roles by name.  They are not even package
;; modified as the KR interface functions take care to wrap them up
;; before passing them on to the KR-system itself. 
;;
;; This means that whenever a KR-interface function returns any 
;; concepts, they should be unwrapped accordingly. 
;;
;; That is, for any KR API function:
;;
;; (defun KR-API-FUNCTION (arg1 arg2 ... argN)
;;   body
;;   )
;;
;; where arg1 ... argN are to refer to concepts/roles from the KR
;; system, then we should do:
;;
;;  (kr-wrap (arg1 arg2 ... argN)
;;    body)
;;
;; Any values coming from the body which are concepts/roles
;; need also to be appropriately unwrapped.
;;
;;  (kr-wrap (c) c) == c
;;
;; must always be true. 
;;
;; We build this with two matching functions, kr-wrapper and
;; kr-unwrapper, such that:
;;
;;         (kr-unwrapper (kr-wrapper c)) == c
;;
;; We also assume that the KR-interface functions only ever return
;; single values! Then we hide the wrapping within the following
;; construction:

(defmacro KR-WRAP 
  ((&rest args) &body body)
  `(let 
       ,(loop for arg in args
	      collect (list arg `(kpml::kr-wrapper ,arg)))
     (let ((result ,@body))
       (if (consp result)
	   (mapcar #'kpml::kr-unwrapper result)
	 (kpml::kr-unwrapper result)))))

;; When time-efficiency becomes an issue, these can be replaced
;; by specific implementations that take care themselves to do
;; the wrapping and unwrapping in appropriate places. The kr-wrap
;; construction allows, for existence, recursive functions to 
;; ignore the wrapping process:
;;
;;   (defun KR-API-FN (c1 c2)
;;     (kr-wrap (c1 c2)
;; 	     ...
;; 	     (kr-api-fn c1a c2a)
;; 	     ...
;; 	     ))
;;
;; This may in particular cases be much efficient if there is a core
;; of the function that only deals with KR entities and only unwraps
;; when returning control to KPML.
;;
;; Because all usage of KR entities will now be assumed to be wrapped
;; appropriately, we can also use the wrapper as a point for obtaining
;; information about what concepts are used, etc.

;; Note that SPL construction relies upon (cf. objects/spls.lisp):
;;
;; (defvar *spl-set-type* 'um-set)
;; (defvar *spl-disjunctive-set-type* 'disjunctive-set)
;; (defvar *spl-relational-types* '(two-place-relation relation))
;;
;; These are the KPML internal names for the concepts/roles, but this
;; still has to be checked/updated if necessary for any upper model that
;; names these concepts differently.
;;
;; For the generalized upper model in OWL (GUM3 in OWL), these concepts
;; are named as:
;;
;;  |UMSet|, |DisjunctiveSet|, |Relating| 

(defparameter *spl-set-type* '|UMSet|)
(defparameter *spl-disjunctive-set-type* '|DisjunctiveSet|)


;; the wrapping takes care of this last one though now...
;;
;; (defparameter *spl-relational-types* '(two-place-relation relation))
