(in-package "KPML")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;COPYRIGHT (C) UNIVERSITY OF SOUTHERN CALIFORNIA, 1987                        ;
;University Of Southern California, Information Sciences Institute            ;
;4676 Admiralty Way                                                           ;
;Marina Del Rey, California 90292                                             ;
;                                                                             ;
;This software was developed under the terms and conditions of Contract       ;
;No. MDA903 81 C 0335 between the Defense Advanced Research Projects          ;
;Agency and the University of Southern California, Information Sciences       ;
;Institute. Use and distribution of this software is further subject to       ;
;the provisions of that contract and any other agreements developed           ;
;between the user of the software and the University of Southern              ;
;California, Information Sciences Institute.                                  ;
;This software is within the scope of the "AGREEMENT FOR SOFTWARE             ;
;EXCHANGE" between BBN Laboratories Incorporated and the University           ;
;of Southern California, dated February 18, 1986.  It is supplied             ;
;"AS IS," without any warranties of any kind.  It is furnished only           ;
;on the basis that any party who receives it indemnifies and holds            ;
;harmless the parties who furnish and originate it against any                ;
;claims, demands or liabilities connected with using it, furnishing           ;
;it to others or providing it to a third party.  THIS NOTICE MUST             ;
;NOT BE REMOVED FROM THE SOFTWARE, AND IN THE EVENT THAT THE                  ;
;SOFTWARE IS DIVIDED, IT SHOULD BE ATTACHED TO EVERY PART.                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; *** IPSI/KPML updates.
;;;
;;; Major change:
;;; KPML-0.8: contains only those functions to do with concept
;;;           annotations, and there is nothing specificially
;;;           tied to any particular KR system.
;;;         * annotate concept now adds info only, it does not
;;;           replace any annotations that have already been
;;;           made.
;;; Also:
;;; *** lack of a lexical item during annotate-concept downgraded
;;;     to a caution, since we often load an upper model before
;;;     lexicons (especially multilingually).  John:IPSI:Dec94
;;;
;;; 2.0 predicate defined explicitly for the following definition to
;;;     avoid clash with the more appropriate use of kb-concept-p as
;;;     a predicate for identifying kb concepts.

(defstruct (kb-concept (:predicate kb-annotation-p))
  "Data structure encoding concept-lexicon definition & data/annotations."
  (doc-strings nil :type list)
  (lex-features nil :type list)
  (lex-items nil :type list))

(defvar *concept-annotations* (make-hash-table :test #'eq))

;;; ----------------------------------------------------------------------
;;; 3.2.45 BUG (multilinguality missing in concept annotations).
;;;
  ;; Nasty bug found by M.Boldasov... well not really a bug (:-), more of
  ;; an oversight, in that the following function just *HAD NOT BEEN UPDATED
  ;; AT ALL TO BE MULTILINGUAL!!* I hope that there are not too many more
  ;; of these around! 
  ;; Fix: treat the lexical item list and the documentation list as
  ;;      multilingual expressions and do a proper multilingual merge
  ;;      using new utility MERGE-SIMPLE-LX-LISTS. 
;;; ----------------------------------------------------------------------

#||
Behaviour before fix:

Following behaviour is stable and incorrect in Agile images.

     (make-annotations 'dm::gui-data 
       :lex-items '(:russian :czech gui-data :bulgarian  gui-multlst))
     =>
     #S(KB-CONCEPT DOC-STRINGS NIL LEX-FEATURES NIL LEX-ITEMS 
      (:RUSSIAN :CZECH GUI-DATA :BULGARIAN GUI-MULTLST))
     
     (annotate-concept dm::gui-data :lex-items (:russian gui-data))
     =>
     #S(KB-CONCEPT DOC-STRINGS NIL LEX-FEATURES NIL LEX-ITEMS 
      (:CZECH :BULGARIAN GUI-MULTLST :RUSSIAN GUI-DATA))
     
So this has messed up the Czech.  Czech was GUI-DATA, now it is GUI-MULTLST.
Action following fix:
     
     (make-annotations 'dm::gui-data 
       :lex-items '(:russian :czech gui-data :bulgarian  gui-multlst))
     =>
     #S(KB-CONCEPT DOC-STRINGS NIL LEX-FEATURES NIL LEX-ITEMS 
       (:RUSSIAN GUI-DATA :CZECH GUI-DATA :BULGARIAN GUI-MULTLST))
     
     (annotate-concept dm::gui-data :lex-items (:russian gui-data))
     =>
     #S(KB-CONCEPT DOC-STRINGS NIL LEX-FEATURES NIL LEX-ITEMS 
       (:RUSSIAN GUI-DATA :CZECH GUI-DATA :BULGARIAN GUI-MULTLST))

Languages stay independent as required.
||#


(defun MAKE-ANNOTATIONS (concept &key (doc-strings nil) 
				 (lex-features nil) (lex-items nil))

  (let ((kb-concept (or (gethash concept *concept-annotations*)
			(setf (gethash concept *concept-annotations*)
			      (make-kb-concept)))))
    (when doc-strings
      (setf (kb-concept-doc-strings kb-concept) 
	    (append (kb-concept-doc-strings kb-concept) doc-strings)))
    (when lex-items
      (setf (kb-concept-lex-items kb-concept)
	    ;; 3.2.45 : do a proper merge of multilingual expressions
	    ;;          rather than the simple append that was there formerly.
	    (merge-simple-lx-lists 
	     (kb-concept-lex-items kb-concept) lex-items))
      (dolist (lex-item lex-items)   
	      (let ((lex (intern (symbol-name lex-item) 
				 (find-package "KPML"))))
		;; Set SEMANTICS feature of each lex item to include 
		;; this concept...
		(if (gethash lex lexicon)
		    (push (kb-getnamedconcept concept)
			  (lexical-item-semantics (gethash lex lexicon)))
		  (caution
		   (format nil
			   "No lexical item for the word named ~a" 
			   lex))))))
    (when lex-features
      (setf (kb-concept-lex-features kb-concept)
	    ;; same here...
	    ;; 3.2.45 : do a proper merge of multilingual expressions rather
	    ;;          than the simple append that was there formerly....
	    (merge-simple-lx-lists 
	     (kb-concept-lex-features kb-concept) lex-features)))
    kb-concept))				


(defmacro annotate-concept (concept &key (doc-strings nil) (lex-features nil)
				    (lex-items nil))

  `(make-annotations 
     ',concept :doc-strings ',doc-strings :lex-features ',lex-features
     :lex-items ',lex-items))

;;; FOR POSSIBLE FUTURE USE
;(defmacro define&annotate-concept 
;	  (concept &key (definition nil) (doc-string "") (lex-items nil)
;                       (lex-features nil))
;  
;  `(setf (gethash ',concept concept-annotations)
;	 (make-kb-concept
;	   :definition 
;	   ,(if definition 
;		`',(loom::generate-concept-definition (kpml-eval definition))
;		(if (gethash concept concept-annotations) 
;		    (kb-concept-definition
;                     (gethash concept concept-annotations))))
;	   :doc-string 
;	   ,(if (and (gethash concept concept-annotations) 
;		     (string-equal doc-string ""))
;		(kb-concept-doc-string (gethash concept concept-annotations))
;		doc-string)
;	   :lex-features 
;	   ,(if lex-features 
;		`',lex-features 
;		(if (gethash concept concept-annotations) 
;		    (kb-concept-lex-features
;                     (gethash concept concept-annotations))))
;	   :lex-items 
;	   ,(if lex-items 
;		`',lex-items
;		(if (gethash concept concept-annotations) 
;		    (kb-concept-lex-items (gethash concept concept-annotations)
;    ))))))

(defun write-annotations (file-pathname)
  
  (with-open-file (stream file-pathname :direction :output
			  :if-exists :new-version)
    (print-mode-and-copyright stream)
    (maphash #'(lambda (key val) (print-annotation key val stream))
	     *concept-annotations*)))

(defun print-annotation (concept annotations stream)

  (let ((strings (kb-concept-doc-strings annotations))
	(features (kb-concept-lex-features annotations))
	(lex  (kb-concept-lex-items annotations)))
    (format stream "~%(penman::annotate-concept ~s" concept)
    (when strings
      (format stream "~%  :doc-strings~%  ")
      (format stream "(")
      (dolist (string strings)
	(prin1 string stream)
	(unless (string-equal string (first (last strings)))
	  (format stream "~%   ")))
      (format stream ")"))
    (when features
      (format stream "~%  :lex-features~%  ")
      (prin1 features stream))
    (when lex
      (format stream "~%  :lex-items~%  ")
      (prin1 lex stream))
    (format stream ")~%")))


(defun Concept-Lexical-Data-In-Lexicon? (concept)
    "Given a concept, checks that its lexical items, if any, are in LEXICON."
    (if (KB-GetConceptLexicalData concept)
      (dolist (lex (KB-GetConceptLexicalData concept) t)
	(if (not (gethash (intern (symbol-name lex) "KPML") LEXICON)) 
	    (return nil)))))

;;; ----------------------------------------------------------------------
;;; Following taken more or less from Penman and made independent
;;; of Loom and so moved to this file rather than the Loom subdirectory.
;;;
;;; IPSI: 12 Jan 95; this function used the loom function directly
;;;       rather than the interface function intended. Changed
;;;       so it is no longer an `interface' function as in Penman.

(defun KB-GETCONCEPTLEXICALDATA (concept) 
  "Given a concept, return the lexical data, if any, associated with it."
  (let ((annotations (gethash (kb-getconceptname concept)
			      *concept-annotations*)))
    (if annotations 
	(kb-concept-lex-items annotations))))




