(in-package "KPML")

;;; File: lexicon-interaction.lisp
;;; 
;;; ----------------------------------------------------------------------
;;; 2.0 provides more open access to some of the decision made during
;;; lexical selection and morphologizing. 
;;; 
;;; Code here is responsible for selection of a lexical item when 
;;; traversal through the network has been completed and for controlling
;;; the appropriate decisions concerning its morphological form.
;;; File ends with some methods that may be specialized upon (typically
;;; for language) for making external information sources (e.g., lexicons,
;;; morphological components) accessible.
;;;
;;; Generation/Lexicalization Behaviour is as follows...
;;; -------------------------------------------------
;;;
;;; All  constituents that  receive   a lexical realization end  up  being
;;; passed to REALIZE-CLASSIFY.
;;;
;;; if TERM-RESOLVE-ID  had previously been   called on that  constituent,
;;; then the  constituent has a particular TERM  already selected, so this
;;; is taken as the selected lexical item.
;;; 
;;; Otherwise, the method  SELECT-TERMS-FROM-LEXICON is called  in order to
;;; come up with a lexical term.
;;;
;;; The selected lexical term is then passed on to the REALIZE-INFLECTIFY
;;; method in order to receive a proper form.
;;; 
;;; ----------------------------------------------------------------------
;;; 2.0.3 and 2.0.62 involve two main changes:
;;;
;;; (1)  when a constituent is being realized by classification rather
;;;      than being lexicalized via term-resolve-id, it used to be the
;;;      case that any association with semantics (e.g., with an SPL
;;;      term) was fully ignored. This is usually ok, but occasionally
;;;      confusing if one has associated a hub with a function and that
;;;      hub contains some explicit candidates via a :lex. It might be
;;;      thought that these :lex candidates would also be reached via
;;;      the association. This is now made the case. Note that we cannot
;;;      just do a normal term-resolution because this would come up with
;;;      candidate lexical items for nonsensical concepts such as the
;;;      default time points (Tempo0, etc.).
;;;
;;; (2)  it used to be the case that when a constituent is realized by
;;;      means of lexify, then no further processing is done on that
;;;      constituent: but this   is,  arguably, an
;;;      oversight:     the  lexification  should    replace the classification
;;;      procedure,  not   the   inflectifying   one.     Thus,  a   call    to
;;;      REALIZE-INFLECTIFY  should also be  triggered in GENERATE-SUBSTRUCTURE
;;;      (in structure.lisp) in the case of a lexify-realized constituent.
;;;      This means that it is ok to combine lexify with inflectify 
;;;      constraints.
;;;
;;; The names of some lexicalization methods are also regularized.
;;; ----------------------------------------------------------------------

(defvar *term-set-selection-method* #'first 
  "this function selects the lexical term from the term set")  ;; 2.0

;;; ----------------------------------------------------------------------
;;; (1) selection of a lexical item on the basis of classify 
;;;     realization statements...

;;; The following function is responsible for the selection of a lexical
;;; item when no semantic constraints are used. Classify-constraints
;;; are applied in order to obtain appropriate lexical items from the lexicon.
;;; The function is called whenever there is a constituent
;;; that is to be lexicalized (either by using classifies or by
;;; other constraints). It's return behaviour varies depending on
;;; whether word rank and below is activated or not. 
;;;
;;; 0.7.9 was mistakenly including the inflectify features in the
;;;       classification process.
;;; 2.0   clisp removed, made more appropriately multilingual
;;; 2.1   more support for prosodies needing access to fundles out
;;;       of their normal positioning.
;;; 3.1   was not clearing the cycle number off function names
;;;       and so was not finding already lexicalized information
;;;       meaning that incorrect relexicalizations were being done.
;;; 3.2   removed a warning about no terms being found whenever there
;;;       were no features to constrain anyway: since this is probably
;;;       because the lexical selection is being done in some other
;;;       way in any case and so is intention. Not finding a lexical
;;;       item where there *are* features remains worth a warning.
;;; ----------------------------------------------------------------------

(defun REALIZE-CLASSIFY (bundle)
  (let ((Feature-List  (list-of-brownboard-elt-classifyspecs Bundle))
        (fundle (list-of-brownboard-elt-functionlist Bundle))
        (classify-and-inflectify-feature-list 
         (loop for Presel in (brownboard-elt-featurespecs  Bundle)
	       collect (selection-def-features Presel)))
        (chosen-word nil))
    (multiple-value-bind
        (terms term-sets hubs)
        (loop for fn-with-tag in fundle               ;; 3.1
              as fn = (remove-fn-tag fn-with-tag)
	      when (find-association fn 'term)
	      collect it into terms
	      when (find-association fn 'termset)
	      collect it into termsets
	      when (find-association fn 'concept)
	      collect it into hubs
	      finally (return (values terms termsets hubs)))
      
      ;; 2.1
      ;; when we have prosodies, we need sometimes to address a fundle
      ;; at some distance from its original use, so that we need to make
      ;; sure that the associated hubs are still accessible. So set
      ;; up a link here and use it as a working memory during each
      ;; complete generation...
      (if hubs
          (setf (gethash (number-functions fundle) *fundle-hub-linkage*) hubs)
        (setf hubs 
              (gethash (number-functions fundle) *fundle-hub-linkage*)))
    
      (cond (terms)
	    (term-sets          

	     ;; already done a term-resolve...
	     (when (> (LENGTH Term-sets) 1)
	       (caution "More than one term set " Term-sets " for Bundle " fundle
			" Using the first first termset."))
	     (setq terms (car term-sets)))
	  
	    (t
	     ;; This is lexical selection by classification...
	     (multiple-value-bind (positive-features negative-features)
		 (extract-classify-features feature-list)
	     
	       ;; 2.0.3 add in selections from :lex in SPLs...
	       ;; 2.0.8 .3 was not prepared for pseudohubs created by 
	       ;;       reification coming through. These are just symbols
	       ;;       and do not represent term graphs, etc.
	       (loop for hub in (remove-duplicates hubs)
		   for lexs = (if (and (boundp hub)
				       (term-graph-p (symbol-value hub)))
				  (fetch-lex-from-spl 
				   hub *current-language-package*)
				nil)
		   when lexs
		   do (typecase lexs
			(cons (setf terms (append lexs terms)))
			(symbol (setf terms (cons lexs terms)))
			(otherwise 
			 (warning "Misformed :lex in SPL for symbol: " hub))))
               
	       (setf terms
		     (select-terms-from-lexicon 
		      (remove-duplicates terms) 
		      positive-features negative-features curlan)))))
      
      (cond (terms
	     ;; reduce to a single candidate...
	     (when (> (length terms) 1)
	       (caution "More than one term " terms " for bundle "  fundle
			". Selecting one." ))
	     (setq chosen-word (funcall *term-set-selection-method* terms))
	     (when show-lexical-selection
	       (printwindow :display-pane 
			    (indent-and-fill 
			     (format nil 
				     "The chosen word is: ~a" chosen-word ))))
             
	     ;; Now  we have a single  word  whose classifies are  appropriate. 
	     ;; Now we  return back up to the caller, the  selected word 
	     ;; with  it's  feature list, instead of the string that would 
	     ;; have been passed back before we were able to do morphology.
	     ;; If no morphology is switched on, then we pass our word 
	     ;; directly to morphology processing...
	     ;;
	     (return-from REALIZE-CLASSIFY 
	       (if *activate-word-rank-and-below*
		   (list Chosen-Word classify-and-inflectify-Feature-List)
		 (Realize-Inflectify 
		  Chosen-Word Classify-and-inflectify-Feature-List curlan))))
	    (t
	     (when feature-list  ;; 3.2
	       (warning "No term(s) found with the features: " feature-list)))))))

;;; ----------------------------------------------------------------------
;;; And a default KPML method for getting the lexicon entry from the
;;; KPML-internally maintained lexicon... This can be replaced, added
;;; to, etc. for accessing different lexical sources.
;;;
 ;; 3.2.31
 ;;  slight behaviour change: this method previously tended to produce
 ;;  NIL if there is a clash between the lexical classify features and
 ;;  and the lexical terms selected on the basis of the semantics of
 ;;  the constituent being generated. Unfortunately, this clash is
 ;;  sometimes justified. For example, if we have a Deictic that is 
 ;;  realized purely by a closed class item selected by a unique
 ;;  combination of classifies, then it is irrelevant that this may
 ;;  refer back to something else that would, in a different context,
 ;;  *not* be realised by, e.g., a pronoun or possessive deictic.
 ;;  The method is therefore changed so that if the result of applying
 ;;  all the classifies and restricting by out-classifies is a single
 ;;  unique lexical item, then we accept this regardless of what the
 ;;  terms selected on semantic grounds may have been. This may not
 ;;  be a fully general solution, so we will have to make sure that
 ;;  behaviour is reasonable for a while.
 ;; 3.2.67 folded in.
 ;;
 ;; 4.0 -- the above was still not quite sufficient for the full-form
 ;;        lexicon of the German resources which really rely only
 ;;        on classification to get the job done. Added a last
 ;;        ditch lexical item selection for this case: need to check
 ;;        that it is not too liberal for the language resources
 ;;        where things are being done properly.
 ;; ----------------------------------------------------------------------

(defmethod SELECT-TERM-FROM-LEXICON 
  (terms classify-features outclassify-features curlan)
  (let ((term-list terms))
	
    ;; get all words from the lexicon with all the classify features
    (loop for x in classify-features
	  as word-list = (remove-duplicates (fetch-lexemes-with-feature x curlan))
	  when word-list
	  do 
	  (if term-list
	      (setq term-list (intersection term-list word-list))
	    (setq term-list word-list)))
    
    ;; remove any words with any outclassify feature
    (setf term-list
	  (remove-if 
	   #'(lambda (x)	
	       (if (lexeme-defined-for-lg-p x curlan)
		   (intersection outclassify-features
				 (fetch-lexicon-features x curlan))
		 (progn
		   (warning "The word " x " is not in the lexicon for language " 
			    curlan ".")
		   nil)))
	   term-list))

    (let ((result
	   (cond ((= (length term-list) 1)
		  term-list)
		 (terms
		  ;; finally, filter against the semantic selections that may have been made...
		  (intersection terms term-list))
		 (t
		  ;; 3.2.67 
		  ;; if there is no semantic filter and *exact* matches for 
		  ;; classify-features, then always prefer these as the safest bet...
		  (let ((exacts 
			 (loop for term in term-list
			       when (set-equal classify-features
					       (fetch-lexicon-info term 'features))
			       collect term)))
		    (if exacts exacts 
		      term-list))))))
      
      ;; 4.0 -- as absolutely last chance, for occasions where perhaps
      ;;        classification is being relied upon exclusively, if 
      ;;        the above yielded no result, but a pure classification
      ;;        gives a unique selection, take that...
      (if result
	  result
	(if terms
	    (let ((result 
		   (select-term-from-lexicon 
		    nil classify-features outclassify-features curlan)))
	      (if (= (length result) 1) result nil))
	  nil)))))

;;; ----------------------------------------------------------------------
;;; 2.0.3
;;; `Official' name of the following changed, so equivalent method added here 
;;; in case anyone has used the old one...
;;; ----------------------------------------------------------------------

(defmethod SELECT-TERMS-FROM-LEXICON 
    (terms classify-features outclassify-features curlan)
  (select-term-from-lexicon 
   terms classify-features outclassify-features curlan))

;;; ----------------------------------------------------------------------
;;; (2) Morphology (when not systemic)...
;;;     2.0 redefined as a method to allow specialization according
;;;         to language (as requested by Knut: Feb98).
;;;     2.1 the default method was still that for English, which can
;;;         confuse when the language is not English and the resource
;;;         developers have not yet fully taken over the morphology
;;;         possibilities... Changed here so that the default is
;;;         rather neutral and does not check any consistency of
;;;         features, etc. (which can only be done wrt a given
;;;         language definition). The old behaviour is then a
;;;         specialization of the method explicitly for English.
;;; ----------------------------------------------------------------------

(defmethod REALIZE-INFLECTIFY (chosen-word grammatical-feature-list lg)
  (prog ((word-from-lexicon NIL)
         (spelling NIL)
         (ending-type NIL)
         (lexical-feature NIL)
         (property-list NIL)
         (lexical-feature-list NIL))
    (cond
     ((Not Chosen-Word)
      (Warning "The chosen word " Chosen-Word " is NIL")
      (RETURN NIL))
     ((value-if-listp Chosen-Word)
      (SETQ word-from-lexicon (fetch-lexicon-info (CAR Chosen-Word) 'instance)))
     ((ATOM Chosen-Word)
      (SETQ word-from-lexicon (fetch-lexicon-info Chosen-Word 'instance)))
     (T (Warning "The chosen word " Chosen-Word " is ill-formed (i.e., not an atom or list)")))
    (cond
     (word-from-lexicon
      (SETQ spelling (Lexical-Item-Spelling word-from-lexicon))
      (SETQ property-list (Lexical-Item-Properties word-from-lexicon))
      (SETQ lexical-feature-list (Lexical-Item-Features word-from-lexicon)))
     (T (Warning "The word " Chosen-Word " is not in the lexicon.")
        (RETURN NIL)))
    ;; here is a place to do language specific checking of whether the features
    ;; classified/inflectified in the grammar are consistent, desirable, etc.
    ;; Vanilla flavour is to just take them as they are and pass them on
    ;; simply removing duplicates... this can then leave several features
    ;; and it is up to generate-inflected-word to do something sensible with
    ;; them. The vanilla generate-inflected-word will just take the first
    ;; of the list... which is not in general necessarily sensible, but at 
    ;; least produced output prompting the grammar developer to provide more
    ;; info... Generate-inflected-word is actually quite a minimal wrapper
    ;; for the language-specifiable method generate-inflected-word-for-language,
    ;; all it really does it put spaces after lexical items... 
    (SETQ ending-type (remove-duplicates lexical-feature-list))
    (SETQ lexical-feature
          (Grammatical-Features-To-Lexical-Feature
           Grammatical-Feature-List (member 'Noun lexical-feature-list)))
    (RETURN (Generate-Inflected-Word 
             spelling ending-type property-list lexical-feature))))


(defmethod REALIZE-INFLECTIFY (chosen-word grammatical-feature-list (lg (eql :english)))
  ;; 2.1 this is basically the old Penman realize-inflectify, adapted for
  ;;     multilingually, updated for KPML, and resurfacing as a method specialized
  ;;     on the language :english only.
  (PROG ((word-from-lexicon NIL)
	 (spelling NIL)
	 (ending-type NIL)
	 (lexical-feature NIL)
	 (property-list NIL)
	 (lexical-feature-list NIL)
	 (possible-ending-types *lexical-entry-ending-types*))
	(cond
	  ((Not Chosen-Word)
	   (Warning "The chosen word " Chosen-Word " is NIL")
	   (RETURN NIL))
	  ((value-if-listp Chosen-Word)
	   (SETQ word-from-lexicon 
		 (fetch-lexicon-info (CAR Chosen-Word) 'instance)))
	  ((ATOM Chosen-Word)
	   (SETQ word-from-lexicon (fetch-lexicon-info Chosen-Word 'instance)))
	  (T (Warning "The chosen word " Chosen-Word 
		      " is not an atom or list")))
	(cond
	 (word-from-lexicon
	  (SETQ spelling (Lexical-Item-Spelling word-from-lexicon))
	  (SETQ property-list (Lexical-Item-Properties word-from-lexicon))
	  (SETQ lexical-feature-list (Lexical-Item-Features word-from-lexicon)))
	 (T (Warning "The word " Chosen-Word " is not in the lexicon.")
	    (RETURN NIL)))
	(SETQ ending-type 
	      (remove-duplicates (intersection lexical-feature-list 
					       possible-ending-types)))
	(cond
	  ((> (LENGTH ending-type)
	      1)
	   (Warning "More than one ending type for the word " word-from-lexicon T "."
		    "The ending types are " ending-type)
	   (RETURN NIL))
	  ((< (LENGTH ending-type) 
	     1)
	   (RETURN  spelling)))
	(SETQ lexical-feature
	      (Grammatical-Features-To-Lexical-Feature
		Grammatical-Feature-List
		(member 'Noun lexical-feature-list)))
	(RETURN (Generate-Inflected-Word spelling (CAR ending-type)
					 property-list lexical-feature))))


 ;; ----------------------------------------------------------------------
 ;; 3.2.20 -- be ultra cautious with the code page...
 ;;
 ;;   Make sure that whenever we go to the lexicon (possibly via user
 ;;   defined methods for accessing external lexicon or morphology
 ;;   components, we first wrap an appropriate rebinding of the
 ;;   code page variable (if we are on a PC running Windows of course).
 ;; ----------------------------------------------------------------------

(defmethod REALIZE-INFLECTIFY :around (chosen-word grammatical-feature-list lg)
  (with-code-page-settings
   (curlan)
   (call-next-method chosen-word grammatical-feature-list lg)))

;;; ----------------------------------------------------------------------
;;; Utilities...

(defun EXTRACT-CLASSIFY-FEATURES (feature-list)
  (let ((outclassify-features nil)(classify-features nil))
    (dolist (feature feature-list)
      (if (and (> (length (symbol-name feature)) 12)
	       (string-equal   
		"outclassify-"
		(string-downcase 
		 (subseq (symbol-name feature) 0 12))))
	  (push (intern (subseq (symbol-name feature) 12) 
			(find-package "KPML"))
		outclassify-features)
	(push feature classify-features)))
    (values classify-features outclassify-features)))

;;;==========================================================================
;;; Note that it also becomes an issue what is meant by `irregular', how are 
;;; we to
;;; recognize in a different language whether something is irregular or not.
;;; Here, we redefine check-word-rank-irregularity so that it is more general
;;; than just for English. We also add a further slot to lexical entries: `stem',
;;; for the purpose of allowing us to avoid complex graphology that should rely
;;; on phonology. In general, a word will be considered irregular, if it has
;;; properties defined that cover the grammatical features constraining choice.

;;; the following global controls whether a grammar developer wishes to make 
;;; use of the hybrid old-style of Nigel lexical entries, with combinations of
;;; of `lexical' features (introduced by inflectify) being converted to
;;; lexical-entry features by means of the defined conversion function.

(defvar *nigel-hybrid-lexicon* t)

(defmethod CHECK-WORD-RANK-IRREGULARITY 
    (Chosen-Word Grammatical-Feature-List curlan)
;;; 0.7.6 irregularity handling generalized...
;;; 2.0   made accessible by making into a method specializeable on language.
  (let ((lexical-item NIL)
	(lexical-feature NIL))
    (cond
     ((Not Chosen-Word)
      (Warning "No word has been chosen before word rank applicability checking.")
      (RETURN-from check-word-rank-irregularity NIL))
     ((value-if-listp Chosen-Word)
      (setf lexical-item (CAR Chosen-Word)))
     ((ATOM Chosen-Word)
      (setf lexical-item Chosen-Word))
     (T (Warning "The chosen word " Chosen-Word " is not an atom or list")))

    (unless (Gethash lexical-item Lexicon)
	    (Warning "The word " Chosen-Word " is not in the lexicon.")
	    (RETURN-from check-word-rank-irregularity NIL))

    (let ((spelling (fetch-lexicon-info lexical-item 'spelling))
	  (property-list (fetch-lexicon-info lexical-item 'properties))
	  (lexical-feature-list (fetch-lexicon-info lexical-item 'features)))

      (if *nigel-hybrid-lexicon*
	  (let ((ending-type 
		 (remove-duplicates (intersection lexical-feature-list 
						  *lexical-entry-ending-types*))))
	    (cond
	     ((> (LENGTH ending-type)
		 1)
	      (Warning "More than one ending type for the word " lexical-item T "."
		       "The ending types for " curlan " are " ending-type)
	      (return-from CHECK-WORD-RANK-IRREGULARITY NIL))
	     ((< (length ending-type)
		 1)

;;;> John: Sep94: an additional possibility is that the lexical entry
;;;> is explicitly marked as (noninflectable). When this occurs it
;;;> can also be treated as being irregular, i.e., fixed.
	      
	      (when (member 'noninflectable lexical-feature-list)
		    (return-from CHECK-WORD-RANK-IRREGULARITY
				 (fetch-lexicon-info lexical-item 'spelling)))

;;;> when here, we know that we have not got an irregular form in the Nigel
;;;> sense. Have to check, however, whether we have a direct irregularity
;;;> specified via the property list.

	      (return-from CHECK-WORD-RANK-IRREGULARITY  
			   (check-direct-property-irregularity
			    lexical-item property-list grammatical-feature-list)))
	     (t (setf ending-type (first ending-type))))

;;;> When we have got this far, then we know the ending type specified in the
;;;> feature list of the lexical entry: this means that we can determine whether
;;;> the lexicon, and/or its writer, thought that the entry was regular or
;;;> irregular. Irregularity means that the form to be used is specified in
;;;> the property list of the lexical entry. Note that there can only be
;;;> one specified ending-type for a lexical item. This used to uniquely
;;;> determine the kinds of entries that were to be expected in the property
;;;> list. Here we weaken this a bit, since if no exception entry is found,
;;;> we assume that the entry is regular in that respect and attempt a normal
;;;> form construction. We do this by calling check-direct-property-irregularity,
;;;> but with the mapped morphological features rather than those stemming
;;;> from the grammar. 

	    (cond ((member ending-type
			   *lexicon-irregular-ending-types*)
		   (SETQ lexical-feature
			 (Grammatical-Features-To-Lexical-Feature
			  Grammatical-Feature-List
			  (member 'Noun lexical-feature-list)))
		   (if (check-direct-property-irregularity
			  lexical-item property-list (list lexical-feature))
		       (return-from CHECK-WORD-RANK-IRREGULARITY 
				      (Generate-Inflected-Word spelling ending-type
								property-list lexical-feature))
		     (return-from CHECK-WORD-RANK-IRREGULARITY nil)))
		  (t (return-from CHECK-WORD-RANK-IRREGULARITY nil))))

;;;> if the language is not English, or the language developer has opted not to
;;;> use the Nigel-style of lexical entry, then we look to see if the selected
;;;> features are covered by an entry on the property list directly.
;;;> Since we probably won't see this horrible mismatch of lexical features
;;;> and grammatical features in newly developed lexicogrammars...

	    (check-direct-property-irregularity 
	      lexical-item property-list grammatical-feature-list))

	    )))

(defun CHECK-DIRECT-PROPERTY-IRREGULARITY
       (word-from-lexicon property-list grammatical-feature-list)
  (let* ((properties (mapcar #'first property-list))
	 (relevant-properties 
	   (remove-duplicates
	     (intersection properties Grammatical-Feature-List))))
	      (cond
		((> (LENGTH relevant-properties)
		    1)
		 (Warning "More than one ending type for the word " 
			  word-from-lexicon T "."
			  "The relevant ending types for this word in " 
			  curlan " are " relevant-properties)
		 (RETURN-from check-direct-property-irregularity NIL))
		((< (LENGTH relevant-properties)
		    1)
		 (RETURN-from check-direct-property-irregularity nil)) ;; here not irregular 

		(t (setf relevant-properties (first relevant-properties))
		   (dolist (x property-list) 
		     (if (eq (car x) relevant-properties)
			 (return-from check-direct-property-irregularity
			   (second x))))))))



;;; ----------------------------------------------------------------------
;;; 2.0.62
;;; The following functions used hardcoded strings that are inserted 
;;; into the generated result in the case of reaching a lexical gap
;;; or a realization failure. This is not very flexible; it is also
;;; unfortunate in as much as they were <lex-gap> and <no realization>
;;; which mess up nicely when we are generating strings for use in
;;; HTML/SGML documents! So here we parameterize them making them
;;; easily changeable in the configuration file, and also change them
;;; in any case so that the default does not conflict with HTML/SGML.
;;; ----------------------------------------------------------------------

(defvar *lexical-gap-string* "[lexical gap]")

(defun GET-GRAPHOLOGICAL-FORM (lex-entry graphological-constraints)
  ;; 0.7.18 fixed up morphological changes for multilinguality.
  ;; 0.9.8  if you want a stem, but there isn't one, taking the spelling
  ;; 2.0.62 parameterize lexical gap string
  ;; 4.0    this is used in GET-FINAL-GRAPHOLOGICAL-FORM and in
  ;;        MORPH-REALIZATIONS. We change it so that it now returns
  ;;        five values, the first is the string to be used as
  ;;        before, the second and third are the gloss and translit
  ;;        fields of the lexical item respectively. The fourth and fifth are
  ;;        a record of the classify/inflectify features that are
  ;;        relevant for lexical choice and the lexeme name itself.
  ;;        MORPH-REALIZATIONS just uses the first value as before. 
  ;;        GET-FINAL-GRAPHOLOGICAL-FORM passes the other values back to its caller.
  ;;
  "graphological constraints is a list of from 
   (lex-entry graph-type graph-value), function returns appropriate string"
  
  (unless lex-entry (setf lex-entry (first graphological-constraints)))
  
  (values
   (cond ((eq (second graphological-constraints) 'property)
	  (third graphological-constraints))
	 ((eq (second graphological-constraints) 'morphosed)
	  (third graphological-constraints))
	 ((gethash lex-entry lexicon)
	  (cond ((and 
		  (eq (second graphological-constraints) 'stem)
		  (not (string= (fetch-lexicon-info lex-entry 'stem) "")))
		 (fetch-lexicon-info lex-entry 'stem))
		(t
		 (fetch-lexicon-info lex-entry 'spelling))))
	 (t
	  *lexical-gap-string*))
   ;;
   ;; 4.0 goodies...
   (fetch-lexicon-info lex-entry 'gloss)
   (fetch-lexicon-info lex-entry 'translit)
   graphological-constraints  
   lex-entry
   )
  )


;;; ----------------------------------------------------------------------
;;; 0.9 work factored out of all-orderings...
;;; 2.0 doesn't break on NIL realization as could sometimes happen
;;;     if lexicon selection fails badly
;;; 2.0.62 also parameterize no realization string...
;;;   N.B.,
;;;     if the flag *no-realization-details* is set T, then the no realization
;;;     string also gives the features for which no realization was found, if
;;;     the flag is not set, then further details are not given.
;;;
;;; 4.0 passes on the gloss and translit fields from the lexical item
;;;      as now retrieved by GET-GRAPHOLOGICAL-FORM... and also adds
;;;      this info in in the cases that we do not pass through
;;;      GET-GRAPHOLOGICAL-FORM... This function now has to return
;;;      four values. It does not return a list as it did previously.
;;;      So this change has to be caught in the caller.
;;;
;;;     language-changes enforced
;;; ----------------------------------------------------------------------

(defvar *no-realization-details* T)
(defvar *no-realization-string* "[No Realization]")

(defun GET-FINAL-GRAPHOLOGICAL-FORM (wbe)
  (let ((curlan (whiteboard-elt-language wbe)))
    (declare (special curlan))
  (let*
      ;;> have added here sensitivity to the possibility of
      ;;> substance bundles coming through too... 
      ;;> (John: 29Apr92: but must also beware of top-level classified fundles
      ;;>  slipping through, e.g., the finite auxiliaries, etc.: so make the
      ;;>  test for either lexify or classifies at this point...) 
      ;; 0.9.9: temporary hack to make sure null stems don't get through...
      ;; 4.0:   whenever we make reference to a lexical item, we also
      ;;          now grab its gloss and translit fields. The only place
      ;;          this function is used (it appears...) is in orderings.lisp
      ;;          which is accordingly updated to expect what is now
      ;;          delivered
      ((realization (whiteboard-elt-realization WBE))
       (hub         (whiteboard-elt-hub WBE))
       (term        (hub->term hub))
       (translit    (fetch-lexicon-info realization 'translit))
       (gloss       (fetch-lexicon-info realization 'gloss))
       (fl (whiteboard-elt-featurelist WBE))
       (real-realiz
	(cond ((eq (whiteboard-elt-id WBE) 'substance)
	       ;; this is ugly: needs some work some time... 
	       (cond ((and (stringp fl)
			   (not (string= fl "")))
		      fl)
		     ((value-if-listp (whiteboard-elt-featurelist WBE))
		      (get-graphological-form 
		       realization (whiteboard-elt-featurelist WBE))
		      )
		     (t
		      (fetch-lexicon-info realization 'spelling)
		      )))

	      ((or 
		(eq (whiteboard-elt-id WBE) 'lexify)
		(eq (whiteboard-elt-id WBE) 'classify))
	       
	       ;; 4.0 if we pass through here, we need to get the lexicon
	       ;;     entry if we are to find gloss and translit values...
	       ;;     these are generally somewhere reachable from the
	       ;;     WBE...

	       (when (eq (whiteboard-elt-id WBE) 'lexify)
		 (setf term (car (whiteboard-elt-featurelist wbe))))

	       (setf gloss (fetch-lexicon-info term 'gloss)
		     translit (fetch-lexicon-info term 'translit))

	       (if (stringp realization) 
		   ;; 2.0 following ensures that this branch does not
		   ;;     break when realization is NIL for some reason
		   (if (string-equal realization "")
		       realization
		     (concat realization " "))

		 ;; 4.0 we may have a null realization here if we changed
		 ;;     language on the way down, so if the lexical term
		 ;;     is in fact a lexical item of the current language
		 ;;     for this constituent, go with it instead of 
		 ;;     complaining... To be addressed at some stage, is
		 ;;     just why we do not get a proper realization. This
		 ;;     is only happening when we have lexifies. Needs
		 ;;     checking then this hack can disappear I expect.
		 ;;
		 (if (lexeme-defined-for-lg-p term curlan)
		     (concat (fetch-lexicon-info term 'spelling) " ")
		   (if *no-realization-details*
		       (concatenate 'string
				    "[no realization: " (format nil "~A" fl) "]")
		     *no-realization-string*
		     ))))
	      (t realization))))
    (values real-realiz gloss translit 
	    (whiteboard-elt-featurelist WBE)
	    term)))
  )

;;; ----------------------------------------------------------------------
;;; Function for making access to lexical information from inquiry 
;;; implementations or their successors more straightforward and potentially
;;; declarativiseable...
;;;
;;; 2.0 changed to a method specializeable on language. The
;;;     default provided here is multilingual.

(defmethod ACCESS-LEXICAL-INFORMATION (item curlan)
  (let* ((function-contents (find 
			      item
			      Associations 
			      :key #'function-association-function))
	 (fac (function-association-term function-contents))
	 (lexeme-of-function 
	   (if (listp fac) (first fac) fac))
	 (lexical-entry (fetch-lexicon-info lexeme-of-function 'instance))
	 (lexical-item-features 
	  (fetch-lexicon-info lexeme-of-function 'features curlan)))
    (values lexical-item-features lexeme-of-function lexical-entry)))

;;;--------------------------------------------------------------------
;;; a few little somethings based on the above to aid lexical feature access..
;;; KPML 0.8 patch: forces the lexical features into the KPML
;;;                 package to enable more ready transportability
;;;                 across inquiry implementations living in 
;;;                 different packages....

;;; First two functions operate on lexical item names and features;
;;; following two do the same operating on the associated microfunctions
;;; that would typically be provided as arguments to an inquiry...

(defun LEXICAL-CLASS-ASCERTAINER (lex-entry-param responses)
  (let* ((lex-entry (if (listp lex-entry-param) 
			(car lex-entry-param) lex-entry-param))
	 (lex-features 
	  (if (lexeme-defined-for-lg-p lex-entry curlan)
	      (fetch-lexicon-features lex-entry curlan)
	    nil))
	 (packaged-responses (mapcar #'(lambda (x) 
					 (intern (string x) "KPML"))
				     responses)))
    (loop for response in packaged-responses
	when (member response lex-features)
	do (return response)
	finally (return (car responses)))))

(defun LEXICAL-FEATURE-PRESENT-P (lex-entry-param feature)
  (let* ((lex-entry (if (listp lex-entry-param) 
			(car lex-entry-param) 
		      lex-entry-param))
 	 (lex-features 
	  (if (lexeme-defined-for-lg-p lex-entry curlan)
	      (fetch-lexicon-features lex-entry curlan)
	    nil)))
    (if (member (intern (string feature) "KPML") lex-features)
	feature
	nil)))


(defun LEXICAL-FEATURE-PRESENT-IN-ASSOCIATION-P 
  (item feature &key (yes nil)(no nil))
  (multiple-value-bind 
      (features name entry)
      (access-lexical-information item curlan)
;; 0.7.35 fix 
    (declare (ignore name entry))
    (cond ((member (intern (string feature) "KPML") features)
	   (if yes yes feature))
	  (t 
	   (if no no
	     (if yes
		 (intern (concatenate 'string *default-negation-prefix*
				      (string yes))
			 "KPML")
	       (intern (concatenate 'string *default-negation-prefix*
				    (string feature))
		       "KPML")))))))



(defun LEXICAL-CLASS-OF-ASSOCIATION-ASCERTAINER (item feature-list)
  (multiple-value-bind (features name entry)
      (access-lexical-information item curlan)
    (declare (ignore features entry))
    (lexical-class-ascertainer name feature-list)))


  ;; 4.0 little utility for unthreading the lexicalization history.
  ;;     Used as a quick hack to get back from the concept to its
  ;;     lexical entries. Probably a better way, or the information
  ;;     could be squirreled away more effectively anyway when
  ;;     it happens. But this might do for now. Only active when
  ;;     the lexicalization history is active to save performance
  ;;     overheads when we are just generating.
  ;;

(defun HUB->TERM (c) 
  (maphash #'(lambda (k v) 
	       (LET ((hub (lex-history-concept v)))
		    (when (equal c hub) 
		      (return-from HUB->TERM 
				   (if (lex-history-term v)
				       (lex-history-term v)
				     (first (lex-history-termset v)))))))
	   *lexical-selection-history*))

