(in-package "KPML")

;;; File: term-resolution.lisp

;;;=========================================================================
;;; HERE WE HAVE AN ATTEMPT TO UNIFY SOME OF THE UGLY VERSIONS OF
;;; term-resolve-id-code SO THAT IT IS EASIER TO MODIFY AND TO DEBUG.
;;;
;;; First, redefine the inquiry implementation; it should always look 
;;; something like this in future: 
;;;
;;; (defun term-resolve-id-code (concept association)
;;;   (LEXICAL-TERM-RESOLUTION concept association))
;;;
;;; In KOMET-PENMAN this definition is the one found as default in the
;;; inquiry-implementations file.
;;; 
;;; If more complicated behaviour is required, then this could be incorporated
;;; here... (e.g., replanning referring expressions, etc.)
;;;----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; More extensive tracing is supplied when the flag
;;; show-lexical-selection is set. This function is so sensitive that it
;;; should be removed from the general list of inquiry implementations
;;; and treated separately:  it is in any case a good start off point
;;; for some more sophisticated treatments of lexical selection. This
;;; version just tries to do what Penman has always done, organized more
;;; perspicuously --- however, on the way it does fix up some pretty
;;; gross bugs/oversights that have been in the old code for years,
;;; i.e., at least as long as the 1989 released version of the inquiry
;;; implementations.  (e.g., inquiry term-resolve-id expects a term to
;;; be returned, the function returned a termset; the function also did
;;; a completely nonsensicle *function* association between a *concept*
;;; and a termset rather than between a *function* and a termset --- its
;;; amazing that the old code has `worked' so long.) Most of the work is
;;; broken out into more readily comprehensible (and traceable) chunks.
;;; Enjoy!
;;;                                                   John:IPSI:17Oct92
;;;                -- modification for ML constraints: John:Kyoto:7Aug94
;;;                -- KPML 0.8: filtering by language moved: John:May95
;;;                -- 1.0.26 multilingual :lex handled OK.
;;;                -- 2.0 lexicon access carried out via generic functions
;;;                       that allow specialization according to language
;;;                       John:Feb98.
;;;                -- 3.1 lexicalization decision placed in a table for
;;;                       ease of access during debugging John:Feb00, Bremen.
;;;=========================================================================

(defvar *show-lexical-selection-flag* nil "even more tracing")

;;; ----------------------------------------------------------------------
(defvar *lexical-history-flag* T)                                  ;;  3.1
(defvar *lexical-selection-cache* nil)
(defvar *lexical-selection-history* (make-hash-table))
(defstruct LEX-HISTORY 
  (concept nil)
  (association nil)
  (nearest-lexicalized nil)
  (term nil)
  (termset nil)
  (features nil)
  (method nil))

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

;;;
;;; Then the main work...
;;;

(defun LEXICAL-TERM-RESOLUTION (concept association)
 "This function takes both the concept to be lexicalized and the grammatical
 constituent (micro-function) realizing the concept in structure and produces
 a lexical item appropriate under all constraints."

 (when *show-lexical-selection-flag*
   (printwindow 
    ':display-pane
    (list
     (format nil ".....ATTEMPTING LEXICAL TERM RESOLUTION")
     (format nil "for concept ~A with grammatical association ~A"
	     concept association))))
 
 (when *lexical-history-flag*               ;; 3.1
   (setf *lexical-selection-cache*
         (make-lex-history :concept concept :association association)))

 ;; June06 : special treatment of numbers that slip through,
 ;;          see corresponding comments in the function definition
 (when (numberp concept)
   (return-from LEXICAL-TERM-RESOLUTION
		(lexical-term-resolution-of-number concept)))
			   
 ;; there may be a :lex specified for the concept in the SPL, find this
 ;; if it exits. All SPL (including keywords) is interpreted with
 ;; respect to the package *current-language-package*, default :kpml.
 ;; (Multiple packages for systemic resources are not however
 ;; currently supported in KPML)
 ;; 1.1 multiple lex values now permitted, selection of one follows from
 ;;     the grammatical constraints present as per normal concept-driven
 ;;     lexical selection.
 (let ((lex-in-spl (fetch-lex-from-spl concept *current-language-package*))

       ;; also need to get the constraints set from the grammar that may have
       ;; been set to hold for the grammatical constituent realizing the
       ;; concept...
       (grammatical-constraints
	(fetch-grammatical-constraints-on association)))

   (when *lexical-history-flag* ;; 3.1
     (setf (lex-history-features *lexical-selection-cache*) grammatical-constraints))
   (cond ((and lex-in-spl (symbolp lex-in-spl))
	  (let ((lex-key
		 (add-to-lexicon-if-necessary
		  lex-in-spl grammatical-constraints)))
            (when *lexical-history-flag*               ;; 3.1
              (setf (lex-history-termset *lexical-selection-cache*) (list lex-key))
              (setf (lex-history-method *lexical-selection-cache*) :spl)
              (setf (gethash concept *lexical-selection-history*) *lexical-selection-cache*))
            (funcall 'Associate association (list lex-key) 'Termset)
            (return-from LEXICAL-TERM-RESOLUTION lex-key)))

	 ((consp lex-in-spl)                      ;; 1.1  new case...
	  (let ((termset lex-in-spl))
	    (when *show-lexical-selection-flag*
	      (format *trace-output*
		      "~% ... Termset (from SPL) is: ~A" termset)
	      (unless termset
		(format *trace-output*
			"~% ... i.e., empty; system was: ~A"
			message-sender)))
	    (setf termset
		  (loop for item in termset
			when (and (lexeme-defined-for-lg-p item curlan)
				  (word-has-valid-features-p
				   grammatical-constraints
				   (fetch-lexicon-features item curlan)))
			collect item))
	    (unless termset
	      ;; nothing gets through the filtering... could be
	      ;; because a non-existent lexeme was used in the SPL
	      (loop for item in lex-in-spl
		    while (lexeme-defined-for-lg-p item curlan)
		    finally
		    (setf termset
			  (list (add-to-lexicon-if-necessary
				 item grammatical-constraints)))))

	    (when *show-lexical-selection-flag*
	      (format
	       *trace-output*
	       "~% ... Grammatically restricted termset becomes: ~A"
	       termset))

            (when *lexical-history-flag*               ;; 3.1
              (setf (lex-history-termset *lexical-selection-cache*) termset)
              (setf (lex-history-method *lexical-selection-cache*) :spl)
              (setf (gethash concept *lexical-selection-history*) *lexical-selection-cache*))
	    (funcall 'Associate association termset 'Termset)
	    (return-from LEXICAL-TERM-RESOLUTION
			 (funcall *term-set-selection-method* termset))))

	 ((and (boundp concept)                            ;; check concept is
	       (typep (symbol-value concept) 'term-graph)) ;; an SPL term
	  ;;
	  ;; desired lexical item was not specified explicitly in the SPL,
	  ;; therefore we have to derive the desired lexical item from the
	  ;; conceptual information...

	  (let* ((candidate-termset 
		  (list-of-near-concepts concept grammatical-constraints))
                 (termset (check-existence-of-terms
			   candidate-termset concept grammatical-constraints))
                 (term (funcall *term-set-selection-method* termset)))

            (when *lexical-history-flag*               ;; 3.1
              (setf (lex-history-term    *lexical-selection-cache*) term)
              (setf (lex-history-termset *lexical-selection-cache*) termset)
              (setf (lex-history-method  *lexical-selection-cache*) :concept)
              (setf (gethash concept *lexical-selection-history*) *lexical-selection-cache*))
	    (funcall 'Associate association termset 'Termset)
	    (when *show-lexical-selection-flag*
              (format *trace-output* "~% ... Termset is: ~A" termset)
              (unless termset
                (format *trace-output* "~% ... i.e., empty; system was: ~A"
                        message-sender)))
	    (return-from LEXICAL-TERM-RESOLUTION term)))

	 (t
          (when *lexical-history-flag*               ;; 3.1
            (setf (lex-history-method  *lexical-selection-cache*) :concept-unbound)
            (setf (gethash concept *lexical-selection-history*) *lexical-selection-cache*))
	  (warning "Concept " concept " is not bound!!")
	  nil))))

;;; ----------------------------------------------------------------------
;;; Support functions...




(defun FETCH-LEX-FROM-SPL (concept spl-package)
  (let* ((lg-pkg (find-package spl-package))
	 (lex-in-pkg (intern "LEX" lg-pkg))
	 (lex-slot (or (global-fetch-feature lex-in-pkg concept)
		       (fetch-atomic-feature lex-in-pkg 
					     (get-symbol-term concept))))
	 (value-of-lex 
	  (if (consp lex-slot)
	      (mapcar #'(lambda (l) (intern (symbol-name l) lg-pkg))
		      lex-slot)
	    (intern (symbol-name lex-slot) lg-pkg))))

    (if (and *show-lexical-selection-flag* value-of-lex)    ;; pure tracing
      (printwindow ':display-pane
		   (list  
		     (format nil "A fitting :lex was found in the SPL")
		     (format nil "Value of lex is: ~A" value-of-lex))))
    value-of-lex))
    

;;; ----------------------------------------------------------------------
;;; Following builds in the assumption that only classify features are
;;; relevant for grammatically imposed constraints. That is, a realization
;;; statement of the form (classify F f) means that the lexical feature
;;; f is relevant for the selection of a lexical item. This is in
;;; contrast to morphological features (inflectify) which are assumed
;;; *not* to be able to determine lexical choice.
;;;
;;; 2.0 April98. Klimtholm Havn, Denmark.
;;;     previously it was built in that classifies were only considered
;;;     from the one association that is given as argument, but this
;;;     precludes multiple constraints from classifies on other functions
;;;     of a fundle from playing any role. This is not strictly correct,
;;;     since classifies should be allowed to constrain selection.
;;;     Therefore, we now find all the functions of the fundle and
;;;     then look for all the classifies of these.. (Made independent
;;;     of CLISP too.)
;;;
;;; 4.0 Jan03. Bremen. 
;;;     Obvious drawback of the above was that grammars like the old
;;;     German grammar which used a full-form lexicon cannot be used
;;;     without change when a non-full-form lexicon is plugged in because
;;;     the grammar uses classifies for inflection features in order
;;;     to ensure that they play a role in selecting the lexical item.
;;;     This is not correct. Need rather to allow the grammar to use
;;;     classify and inflectify feature properly, but to have an
;;;     an additional mode which forces the inflection features to
;;;     be considered in lexical selection: this is then the functionality
;;;     required for a full-form lexicon. Thus, for German resources
;;;     for KPML4+ the old classifies have been changed to inflectifies
;;;     where appropriate.
;;;
;;;     However, not checked yet... often the inflectifies actually
;;;     aren't even on the blackboard by the time we do a term-resolution
;;;     so the change wouldn't have much effect... Needs watching.

(defun FETCH-GRAMMATICAL-CONSTRAINTS-ON (association)
  (let* ((fundle 
	  (remove-duplicates
	   (cons association
		 (loop for x in Blackboard
		     when (and (listp x)
			       (equal (car x) 'complex-object)
			       (member association (cdr x)))
		     append (cdr x)))))
	 (constraints 
	  (loop for x in Blackboard
	      when (and (listp x)
			(Equal (CAR x) 'Classify)
			(member (Second x) fundle))
	      append (cddr x))))

    (if (and *show-lexical-selection-flag* constraints)    ;; pure tracing
	(printwindow ':display-pane
		     (list  
		      (format 
		       nil "The following grammatical constraints hold:") 
		      (first 
		       (indent-and-fill (format nil "~A" constraints))))))
    constraints))

;;; ----------------------------------------------------------------------
;;; 1.0.26
;;;  If a lexical item was specified directly in an SPL and this
;;; lexical item exists, but *not* for the current language, then
;;; we used to get a NIL be converted to a null string coming through.
;;; This is not appropriate behavior, since actually, not existing
;;; for the current language should be the same as not existing at 
;;; all. 1.0.26 changes the behaviour accordingly; actually, the following
;;; function was just not multilingual.
;;;
(defun ADD-TO-LEXICON-IF-NECESSARY (lex-value constraints)
  "If the specified lexical item is not in the lexicon, add it in with the
   given constraints as its lexical features"
  (if (lexeme-defined-for-lg-p lex-value curlan)   ;; 1.0.26
      lex-value
    (let ((*merging-active* T))                    ;; 1.0.26
      (warning "The word " lex-value
	       " is not in the lexicon for language "
	       curlan " --- adding new lexical item with features " 
	       constraints)
      (add-string-to-lexicon (symbol-name lex-value) constraints))))

(defun LIST-OF-NEAR-CONCEPTS (concept grammatical-constraints)
  "Look to find the nearest concepts that have appropriate lexical items attached, ignoring the most general concepts of THING and UM-THING and ordering results so that most specific comes first."
  (let ((lexical-item-set nil)
	(semantic-types (sort (term-type concept) #'kb-superp))
	kb-concept)

    (if *show-lexical-selection-flag*    ;; pure tracing
	(printwindow 
	 :display-pane
	 (list  
	  (format nil "Searching for nearest concepts to ~A that" concept)
	  "have appropriate lexical items directly attached."
	  (format nil "These have as semantic type(s): ~A" semantic-types))))

    (dolist (type semantic-types)
      (unless (or (eq type *thing-name*) (eq type *upper-model-thing-name*))
	(setf kb-concept (KB-getnamedconcept type))

	(if *show-lexical-selection-flag*    ;; pure tracing
	    (printwindow 
	     :display-pane
	     (list  
	      (format nil "Semantic type ~A corresponds to concept ~A"
		      type kb-concept) 
	      (format nil "in package: ~A" (kb-package)))))

	(if kb-concept
	    (let ((nearest-concepts 
		   (NearestSuperCsWithLexicalItems
		    (list kb-concept) grammatical-constraints)))
	      (if *show-lexical-selection-flag*
		  (printwindow 
		   :display-pane
		   (list  
		    (format nil 
			    "Nearest concepts found to this, with matching grammatical features: ~A" 
			    grammatical-constraints)
		    (format nil "are: ~A" nearest-concepts)
		    "Note that there could have been other lexical items attached to"
		    "concepts but whose lexical features were not compatible with"
		    "the specified grammatical/lexical features!!")))
              (when *lexical-history-flag*               ;; 3.1
                (setf (lex-history-nearest-lexicalized 
		       *lexical-selection-cache*) nearest-concepts))
	      (setf lexical-item-set
		(append lexical-item-set
			(first (rest (first nearest-concepts))) 
			)))
	  
	  (warning "Semantic type " type " not found in knowledge base"))))

    lexical-item-set))


(defun CHECK-EXISTENCE-OF-TERMS (termset concept features)
  "Check that the found term set includes something that is usable as 
   a lexical item; must return a LIST!"
  (cond ((or (null termset)(equal termset '(thing)))
	 (if *show-lexical-selection-flag*
		  (printwindow ':display-pane
			 (list  
			   (format nil 
				   "No appropriate lexical items found."))))
	 (or
	   (when (term-type concept)
	     (warning "Adding new lexical item for " concept)
	     (list 
	      (add-string-to-lexicon 
	       (symbol-name (first (term-type concept))) 
	       features)))
	   (when (null (term-type concept))
	     (warning "No concept association for " concept) 
	     (list (add-string-to-lexicon (symbol-name concept) features)))))
	(t
	 termset)))

;;;-------------------------------------------------------------------------
;;; this is the other function that was in the deleted ISI Penman file...
;;; 2.0 definition changed to use the more generic lexical feature
;;;     facilities defined in lexicon-interaction.lisp, etc.

(defun WORD-HAS-VALID-FEATURES-P (features-required features-of-word)
  "Given a list of features which include OUTCLASSIFY-feature's return T 
   if features of
   word have no outclassify-feature and have all not outclassified features."
  (let ((feature-intersection-list nil))
    (multiple-value-bind (classify-features outclassify-features)
	(extract-classify-features features-required)
      (setq feature-intersection-list 
	(intersection classify-features features-of-word))
      (if (and (= (length feature-intersection-list)
		  (length classify-features))
	       (every #'(lambda (x) (member x classify-features)) 
		      feature-intersection-list)
	       (not (intersection outclassify-features features-of-word)))
	  t
	nil))))

;;; ----------------------------------------------------------------------
;;; Following   redefined      from         term-resolution.lisp    in
;;; ml-penman-lexicon-patch.lisp no  longer had  the desired  behavior
;;; (tendency   to  find uselessly  high   concepts in the inheritance
;;; hierachy plus  reliance on  the existence  of a concept  `thing');
;;; updated according to changes carried  out in new  term-resolution.
;;; Further  updated  to  make   use of  the  get-concept-lexicon-data
;;; function  (John:IPSI:Dec94),      also     here    redefined   for
;;; multilinguality.
;;; 0.9: uses the non-speedupable parse-clause.

(defun GET-CONCEPT-LEXICAL-DATA (concept)
  (mapcar #'(lambda (x) 
	      (intern (symbol-name x) (find-package "KPML")))
	  (always-parse-clause (KB-GetConceptLexicalData concept)
			       curlan)))


;;; KPML 0.8: filtering of terms by language moved to here, so that
;;;   attached language items of the wrong language do not stop
;;;   ascent of the hierarchy. Code also made more readable.
;;; 2.0: methods used that are specializeable on language so that
;;;   lexicon access may be readily parameterized.
;;; 4.0: an addition piece of information for tracing added.
;;;
(defun NEARESTSUPERCSWITHLEXICALITEMS (ConceptList list-of-features)
  "Investigate SuperCs of concepts in ConceptList until a generation is found 
   with lexical tokens."
  (cond
    ((Null ConceptList)
     nil)
    ((progn
       ;; 4.0 ------- additional tracing info --------------
       (when *show-lexical-selection-flag*
	 (let ((possible-items
		(loop for c in ConceptList
		      for item in (Get-Concept-Lexical-Data  c)
		      when (lexeme-defined-for-lg-p item curlan)
		      collect item)))
	   (when possible-items
	     (printwindow ':display-pane
		   (list  
		    (format nil "Concept ~A has these lexical items attached:")
		    (format nil "  ~A  " possible-items))))))
       
       ;;   --------- as you were -------------------------
       (loop for c in ConceptList 
	   when
	   (loop for item in (Get-Concept-Lexical-Data  c)
		 thereis (and (lexeme-defined-for-lg-p item curlan)
			      (word-has-valid-features-p 
			       list-of-features
			       (fetch-lexicon-features item curlan))))
	   collect (list
		    c
		    (loop for item in
			  (Get-Concept-Lexical-Data c)
			  when (and 
				(lexeme-defined-for-lg-p item curlan)
				(word-has-valid-features-p 
				 list-of-features
				 (fetch-lexicon-features item curlan)))
			collect item)))))
    (T (NearestSuperCsWithLexicalItems
	 (let (supercs) 
	   (dolist (c ConceptList supercs)
	     (setq supercs 
		   (remove-duplicates 
		    (append supercs (KB-ImmediateSuperCs c))))))
	 list-of-features))))


;;; ----------------------------------------------------------------------
;;; 4.0 following is an experimental extension being tested for the
;;;     German grammar. The idea is that it is often necessary for 
;;;     languages with lexical gender to grab the lexical information
;;;     from an antecedent of a pronoun, relative pronoun, etc. We
;;;     attempt this here by going back up the term-graph tree in
;;;     cases where we do not find the necessary lexicalizations
;;;     locally. This relies on the lexicalization having been done
;;;     at a higher rank. So here is a variant of lexical term resolution
;;;     which just goes searching for an appropriate already done
;;;     lexicalization...

(defun LEXICAL-TERM-RESOLUTION-ON-ANTECEDENT (concept association)
  (if (boundp concept)
      (let* ((termgraph (symbol-value concept))
	     (symbol (term-graph-symbol termgraph)))
	;; 
	;; The concept that comes in is probably minimal, since we are
	;; dealing with an anaphor... If it is not minimal, then we
	;; revert back to a full lexical term resolution...
	;;
	(when (term-graph-type termgraph)
	  (return-from 
	   LEXICAL-TERM-RESOLUTION-ON-ANTECEDENT
	   (lexical-term-resolution concept association)))

	;;
	;; go up the parents and look for a symbol-identical
	;; piece of semantics... For the moment just follow direct
	;; heads. This will be a start that is ok for modification
	;; in nominal groups for a while.
	;;
	(let* ((parent (term-graph-parent termgraph))
	       (parent-parent (term-graph-parent (symbol-value parent)))
	       (pp-tg (symbol-value parent-parent)))
	  (if (and (equal symbol (term-graph-symbol pp-tg))
		   (term-graph-type pp-tg))
	      ;; 
	      ;; bingo... problem is that the associations are locally bound
	      ;;          so that we do not get access to those of previous
	      ;;          cycles...  So we use a doobious global variable
	      ;;          that appears to accumulate all the associations that
	      ;;          have ever been made. This needs to be hunted down
	      ;;          and made by default to empty with each generation.
	      ;;          For a long session it gets very long. It seems only to
	      ;;          be pushed to and is never used... curious. Set a flag
	      ;;          and default for initialization in variables.lisp.
	      ;;
	      (loop for f in cumulative-associations
		    when (and (equal (function-association-concept f) parent-parent)
			      (function-association-term f))
		    do (return-from 
			LEXICAL-TERM-RESOLUTION-ON-ANTECEDENT
			(function-association-term f)))
	    (warning "No antecedent found for " concept ))))))
		
   ;; ----------------------------------------------------------------------
   ;; June06
   ;;
   ;; in some cases, with perhaps curious inquiry implementations,
   ;; a number slips through as the concept. We head this off at
   ;; the pass and return an on-the-fly created lexeme to
   ;; to represent it. This may not be the best thing to do...
   ;; We also give the lexical entries for the numbers a standardized
   ;; name so we don't multiply entries pointlessly: it would
   ;; be possible in theory for this to clash with a user
   ;; defined lexical entry but we make this unlikely
   ;;
(defun LEXICAL-TERM-RESOLUTION-OF-NUMBER (number) 
  (let* ((value number)
	 (lexname (intern 
		   (format nil "DIGIT%%-~A" number)
		   (find-package "KPML")))
	 (lexitem 
	  (load-ml-lexicon
	   `(:name ,lexname :spelling ,(format nil "~A" value)
		   :gloss :number
		   :features (CARDINAL NUMERAL)
		   :properties ((ARABICPROP ,value))))))

      (when *show-lexical-selection-flag*
	(printwindow 
	 ':display-pane
	 (list
	  (format nil "~% ... Picked out a number and returning it: ~S" lexname))))

      lexname))


  
