(in-package "KPML")

;;; File: morphology.lisp

;;; Contains the point of contact with morphological processes for
;;; languages covered. A selection of methods for enforcing various
;;; phonologically induced `morphological' changes are included, in
;;; particular the original function for English from Penman changed
;;; to be an English-specific method, the additions for French from
;;; ITRI (also changed to be a French-specific method), and a
;;; Spanish-specific method from UPM. There should be a standardized
;;; place and provision for loading these things some time. At
;;; present additional languages should just define specializations
;;; of the relevant methods and add these into some standard site
;;; specific additions that get loaded whenever they want to work 
;;; with those resources.
;;;
;;; 2.0.11 
;;; further streamlining so that inflection behaviour can be changed
;;; on the fly if inherited from existing behaviours. Particularly
;;; for use when teaching.  Also cleans up the main function somewhat,
;;; to use methods for all languages.

;;; KPML 1.1 does not allow there to be no systemic morphology option...
(set-penman-feature :morphology 'ml-systemic)

;;;---------------------------------------------------------------
;;; KPML-addition; John:IPSI:25Jan95
;;; Patch 0.7.4
;;;
;;; Following adds some limited language conditionalization to the
;;; use of inflectify features for controlling irregular word
;;; forms.
;;; 2.0.1 but not very much, redo here as a proper method...
;;;
;;; 2.0 phonological-processing redefined as a method to allow language
;;;     conditionalization.
;;;
;;; Now, if the language being used is not English, 
;;; generate-inflected-word lifts its results directly out
;;; of the property list without messing around with any
;;; hardwired string operations.
;;;
;;; The generic method REALIZE-INFLECTIFY is now defined as a 
;;; method specializeable for language. For new languages it
;;; should therefore stop control passing through here if those
;;; languages do not want to use any of the morphological/phonological
;;; options given here.
;;;----------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Following global can be set in the configuration file as necessary.
;;; :kim and :kim-english are, for example, standard introductory 
;;; grammar fragments that are used when introducing KPML. They should
;;; not be considered full language varieties, but more temporary
;;; objects.
;;; ----------------------------------------------------------------------

(defvar *language-inflection-behaviours* 
	'((:kim         . :english)
	  (:kim-english . :english))
  "Association list of new languages and the existing languages that they
   should inherit their inflection behaviour from.")

;;; ----------------------------------------------------------------------
;;; The main function, tidied up a bit...
;;; ----------------------------------------------------------------------

(defun GENERATE-INFLECTED-WORD (Spelling Ending-Type 
				Properties Inflected-Form)
  (declare (special curlan))
  (case curlan 
    (;; the oldest, for newer varieties, use methods as below...
     (:english :french)
     (concatenate 'string
       (generate-inflected-word-for-language
	Spelling Ending-type Properties Inflected-form curlan)
       " "))
    (otherwise
     ;; 2.0.1 was still using the English, no idea why since I'd
     ;;       said that it shouldn't in the comments above way back...
     ;; 2.0.11 fine and good not to be English-centric, but this
     ;;       makes it awkward to define languages on the fly that
     ;;       inherit their inflection properties from existing lgs,
     ;;       particularly for students using limited KPML instantiations.
     ;;       So, provide another way out that can also be setup in
     ;;       the configuration file...
     ;; 3.1   this left the word-form generation methods with a quandry
     ;;       since they could not decide on what ending-type the
     ;;       undefined language had, so the default method passes them
     ;;       all on. This is no good here, since the generate-inflected-word
     ;;       method often wants a single one (for English e.g.). So 
     ;;       extended a bit... If we inherit inflection behaviour,
     ;;       we also look to see if we have a set of ending types
     ;;       defined for the language we are inheriting from.
     (let ((inherited (assoc curlan *language-inflection-behaviours*)))
	 (if inherited
	     (let* ((curlan (cdr inherited))
                   ;; 3.1
                   (inherited-ending-type 
                    (if (assoc curlan *ml-lexical-entry-ending-types*)
	                (first (remove-duplicates 
                                (intersection ending-type
                                              (cadr (assoc curlan *ml-lexical-entry-ending-types*)))))
                      ending-type)))
               (generate-inflected-word 
		spelling inherited-ending-type properties inflected-form))
	   (concatenate 
	       'string
	     (generate-inflected-word-for-language
	      spelling ending-type properties inflected-form curlan)
	     " "))))))


;;; ------------------------------------------------------------------
;;; 2.0.1 a new point of language conditionalization that got missed
;;;       in the 2.0 release.... The base case here returns the
;;;       stem or some property if that is selected directly...

(defmethod GENERATE-INFLECTED-WORD-FOR-LANGUAGE
	   (spelling Ending-type Properties Inflected-form lg)
  (cond
   ((Not (And (Stringp Spelling)
              (Or (Not Properties)
                  (value-if-listp Properties))))
    (Warning "Invalid inflection information, unable to generate word inflection")
    nil)
   ((Equal Ending-Type 'Irr)
    (get-lexical-property-value inflected-form Properties))
   (t spelling)))

;;; ----------------------------------------------------------------------
;;; for example,
;;; ----------------------------------------------------------------------

(defmethod GENERATE-INFLECTED-WORD-FOR-LANGUAGE
	   (Spelling Ending-type Properties Inflected-form (lg (eql :english)))
  (generate-inflected-english-word
   Spelling Ending-type Properties Inflected-form))

;;; ----------------------------------------------------------------------
;;;  making the Spanish act like English...
;;;
 ;; 3.2.54
 ;;  the following is a bit of a hack: it appears that the morphology
 ;;  features are not really very explicitly defined for Spanish, resulting
 ;;  in it not being always known whether or not a word can be inflected.
 ;;  The following method specialization takes the view that if we 
 ;;  do not have both properties and a form to inflect, then we won't
 ;;  bother...
;;; ----------------------------------------------------------------------

(defmethod GENERATE-INFLECTED-WORD-FOR-LANGUAGE
           (Spelling Ending-type Properties Inflected-form (lg (eql :spanish)))
  (if (and properties inflected-form)
      (generate-inflected-english-word
       Spelling Ending-type Properties Inflected-form)
    spelling))

;;; ----------------------------------------------------------------------
;;; Additional language methods... (2.0.11)
;;; ----------------------------------------------------------------------

(defmethod GENERATE-INFLECTED-WORD-FOR-LANGUAGE
    (Spelling Ending-type Properties Inflected-form (lg (eql :dutch)))
  (concatenate 'string
               (if (or (equal ending-type 'irr)
                       (equal ending-type 'strong))
                   (generate-word-form Spelling Ending-type Properties Inflected-form)
                 Spelling)
               " "))

(defmethod GENERATE-INFLECTED-WORD-FOR-LANGUAGE
    (Spelling Ending-type Properties Inflected-form (lg (eql :japanese)))
  (generate-word-form-base-case 
   Spelling Ending-type Properties Inflected-form))

;;; --------------------------------------------------------------------
;;; And back to how it was pre-2.0.1...
;;; ----------------------------------------------------------------------

(defun GENERATE-WORD-FORM-BASE-CASE 
       (spelling ending-type properties inflected-form)
  (declare (ignore ending-type properties inflected-form))
  spelling)

;;; -----------------------------------------------------------------------------
;;; The place where English regular morphology lives...
;;; (Hey, don't complain this is ugly... this is *history* !! :-)
;;; 3.1 complained mightily if there is no ending type, presumably
;;;     because it was originally written so that only things that
;;;     would be inflected came through here, but now I think almost
;;;     every word comes here and some of these just are not inflectable.
;;;     So, allow an ending-type of nil to just give the stem back
;;;     with complaining. Make this change for the other equivalent
;;;     word inflecters too.
  ;; ----------------------------------------------------------------------
  ;; 3.2.38
  ;;   A quote was doubled in the following function! Making
  ;;   edpastparticiple misbehave. A wonder it has not caused
  ;;   trouble elsewhere...
  ;; 3.2.53
  ;;   an empty string coming in here as spelling could sometimes
  ;;   get us to break... not sure why it was not before...
  ;;   now just check that the string is at least 2 characters long
  ;;   (otherwise we cannot inflect it)  and if it is not
  ;;   don't worry about inflecting it.
  ;; ----------------------------------------------------------------------

(defun GENERATE-INFLECTED-ENGLISH-WORD 
    (Spelling Ending-type Properties Inflected-form)
    ;; 3.2.53
    (if (< (length spelling) 2)
	spelling
      (PROG 
       ((stem Spelling)
	(stem-minus-last-letter (subseq Spelling 0 (- (length spelling) 1)))
	(last-letter (subseq Spelling (- (length spelling) 1) (length spelling)))
	(next-to-last-letter (subseq Spelling (- (length spelling) 2) (- (length spelling) 1)))
	(possible-inflected-forms '(Pluralform Comparativeform Superlativeform Pastform 
					       Edparticipleform Ingparticipleform 
					       Firstsingularform Secondsingularform 
					       Thirdsingularform Verbpluralform 
					       Firstsingularpastform Secondsingularpastform 
					       Thirdsingularpastform Pluralpastform))
	(possible-ending-types *lexical-entry-ending-types*)
	(inflected-spelling NIL))
    ;; 3.1
    (unless ending-type (return spelling))
    (cond
	  ((Not (And (Stringp Spelling)
		     (symbolp Ending-Type)
		     (member Ending-Type possible-ending-types)
		     (Or (Not Properties)
			 (value-if-listp Properties))
		     (Or (Not Inflected-Form)
			 (And (symbolp Inflected-Form)
			      (member Inflected-Form possible-inflected-forms)))))
	   (Warning "Invalid inflection information, unable to generate word inflection")
	   (RETURN NIL)))
	(cond
	  ((And (Equal Ending-Type 'Es-ed)
		(Not (member next-to-last-letter '("a" "o" "u" "e")))
		(Equal last-letter "y"))
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT 
									      stem-minus-last-letter 
									      "ies")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (CONCAT stem-minus-last-letter "ied")))
		 (Edparticipleform (SETQ inflected-spelling (CONCAT stem-minus-last-letter "ied")))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'Es-ed)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "es")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (CONCAT stem "ed")))
		 (Edparticipleform (SETQ inflected-spelling (CONCAT stem "ed")))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'S-*ed)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (CONCAT stem last-letter "ed")))
		 (Edparticipleform (SETQ inflected-spelling (CONCAT stem last-letter "ed")))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem last-letter "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'S-ed)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (CONCAT stem "ed")))
		 (Edparticipleform (SETQ inflected-spelling (CONCAT stem "ed")))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'S-d)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (CONCAT stem "d")))
		 (Edparticipleform (SETQ inflected-spelling (CONCAT stem "d")))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem-minus-last-letter "ing"))
				    )
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type '*-Irr)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (Get-Lexical-Property-Value 'Pastform
								       Properties)))
		 (Edparticipleform (SETQ inflected-spelling (Get-Lexical-Property-Value
							     ;; 3.2.38
							      'Edparticipleform
							      Properties)))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem last-letter "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((And (Equal Ending-Type 'S-irr)
		(Equal last-letter "e"))
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (Get-Lexical-Property-Value 'Pastform
								       Properties)))
		 (Edparticipleform (SETQ inflected-spelling (Get-Lexical-Property-Value '
							      Edparticipleform
							      Properties)))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem-minus-last-letter "ing"))
				    )
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'S-irr)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "s")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (Get-Lexical-Property-Value 'Pastform
								       Properties)))
		 (Edparticipleform (SETQ inflected-spelling (Get-Lexical-Property-Value '
							      Edparticipleform
							      Properties)))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((And (Equal Ending-Type 'Es-irr)
		(Not (member next-to-last-letter '("a" "o" "u" "e")))
		(Equal last-letter "y"))
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT 
									      stem-minus-last-letter 
									      "ies")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (Get-Lexical-Property-Value 'Pastform
								       Properties)))
		 (Edparticipleform (SETQ inflected-spelling (Get-Lexical-Property-Value '
							      Edparticipleform
							      Properties)))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'Es-irr)
	   (Case Inflected-Form (Thirdsingularform (SETQ inflected-spelling (CONCAT stem "es")))
		 ((Pastform Firstsingularpastform Pluralpastform Thirdsingularpastform)
		  (SETQ inflected-spelling (Get-Lexical-Property-Value 'Pastform
								       Properties)))
		 (Edparticipleform (SETQ inflected-spelling (Get-Lexical-Property-Value '
							      Edparticipleform
							      Properties)))
		 (Ingparticipleform (SETQ inflected-spelling (CONCAT stem "ing")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'Irr)
           ;; 2.0.1 But why was the following *SO* ugly... think I'll rewrite this bit of history,
           ;;       there are limits...
           (if (member inflected-form
                       '(firstsingularform secondsingularform thirdsingularform pluralform
                                           firstsingularpastform secondsingularpastform
                                           thirdsingularpastform pluralpastform edparticipleform
                                           ingparticipleform pastform
                                           ;; 2.0.1 these were missing!
                                           comparativeform superlativeform
                                           ))
               (setf inflected-spelling 
                     (get-lexical-property-value inflected-form Properties))
             (setq inflected-spelling stem)))
	  ((And (Equal Ending-Type 'Er-est)
		(Not (member next-to-last-letter '("a" "o" "u" "e")))
		(Equal last-letter "y"))
	   (Case Inflected-Form (Comparativeform (SETQ inflected-spelling (CONCAT 
									    stem-minus-last-letter 
									    "ier")))
		 (Superlativeform (SETQ inflected-spelling (CONCAT stem-minus-last-letter "iest")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'Er-est)
	   (Case Inflected-Form (Comparativeform (SETQ inflected-spelling (CONCAT stem "er")))
		 (Superlativeform (SETQ inflected-spelling (CONCAT stem "est")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'R-st)
	   (Case Inflected-Form (Comparativeform (SETQ inflected-spelling (CONCAT stem "r")))
		 (Superlativeform (SETQ inflected-spelling (CONCAT stem "st")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type '*Er-*est)
	   (Case Inflected-Form (Comparativeform (SETQ inflected-spelling (CONCAT stem last-letter 
										  "er")))
		 (Superlativeform (SETQ inflected-spelling (CONCAT stem last-letter "est")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((And (Equal Ending-Type 'Es)
		(Not (member next-to-last-letter '("a" "o" "u" "e")))
		(Equal last-letter "y"))
	   (Case Inflected-Form (Pluralform (SETQ inflected-spelling (CONCAT stem-minus-last-letter 
									     "ies")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'Es)
	   (Case Inflected-Form (Pluralform (SETQ inflected-spelling (CONCAT stem "es")))
		 (otherwise (SETQ inflected-spelling stem))))
	  ((Equal Ending-Type 'S)
	   (Case Inflected-Form (Pluralform (SETQ inflected-spelling (CONCAT stem "s")))
		 (otherwise (SETQ inflected-spelling stem)))))
	(RETURN  inflected-spelling ))))




(defun GENERATE-WORD-FORM (Spelling Ending-type Properties Inflected-form)
  (declare (ignore spelling ending-type))
  (cadr (assoc inflected-form properties)))


;;;--------------------------------------------------------------------------
;;; end of patch 0.7.4

;;;=====================================================================
;;; KOMET-PENMAN update...
;;; NOTE:
;;; Patch to use the Apr92 and after  versions of Nigel (as split into
;;; regions)
;;;        (this function used to be in boards.lisp)
;;;
;;; Updated Dec94 (John): to allow different languages...
;;; ====================================================================

;;; Conversion of inflectify features used in the grammar to the actual
;;; features that appear in the properties list of lexical entries...

(defvar *show-morphology-selection-flag* nil)

(defun GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE
  (Grammatical-Features Noun-Flag)
  (let ((generator-fn
	 (third (assoc curlan *language-morphology-profiles*))))
    (when generator-fn
	  (if (fboundp generator-fn)
	      (apply generator-fn
		     (list grammatical-features noun-flag))
	    (warning "Undefined grammatical to lexical feature conversion function specified (" generator-fn ") for language " curlan)))))



;;;
;;;  ENGLISH
;;;  -------
;;;


(defun ENGLISH-GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE
  (grammatical-features noun-flag)
  (PROG (features
	 (Valid-Grammatical-Inflection-Features 
	   '(Plural-form Singular-form Firstperson-form 
                    Secondperson-form Thirdperson-form 
		    Present-form Past-form Edparticiple 
		    Ingparticiple Stem Noun-stem adj-neutral-form
		    superlative-form
		    comparative-form

		    pluralpastform    ;; these composites do not appear anyway
		    verbpluralform
		    thirdsingularform
		    thirdsingularpastform
		    firstsingularform
		    )))
	(SETQ Features (remove-duplicates 
			 (intersection Grammatical-Features 
				       Valid-Grammatical-Inflection-Features)))
	(SETQ Features (remove-duplicates Features))
	(when *show-morphology-selection-flag*
	      (format t "~% ...Complete constraints from grammar: ~A" grammatical-features)
	      (format t "~% ...Morphology: constraints from grammar: ~A" features))
	(cond
	  ((And Noun-Flag (Set-Equal Features '(Plural-form)))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Singular-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Firstperson-form Singular-form Present-form))
	   (RETURN 'Firstsingularform))
	  ((Set-Equal Features '(Secondperson-form Singular-form Present-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Thirdperson-form Singular-form Present-form))
	   (RETURN 'Thirdsingularform))
	  ((Set-Equal Features '(Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Firstperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Secondperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Thirdperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Firstperson-form Singular-form Past-form))
	   (RETURN 'Firstsingularpastform))
	  ((Set-Equal Features '(Secondperson-form Singular-form Past-form))
	   (RETURN 'Pluralpastform))
	  ((Set-Equal Features '(Thirdperson-form Singular-form Past-form))
	   (RETURN 'Thirdsingularpastform))
	  ((Set-Equal Features '(Thirdperson-form Plural-form Past-form))
	   (RETURN 'Pluralpastform))
;;; 0.9 added, since the grammar now tends to generate full paradigms
	  ((Set-Equal Features '(Firstperson-form Past-form Plural-form))
	   (RETURN 'Pluralpastform))
	  ((Set-Equal Features '(Past-form Plural-form))
	   (RETURN 'Pluralpastform))
	  ((set-equal features '(present-form secondperson-form))
	   (return nil))
	  ((set-equal features '(past-form secondperson-form))
	   (return 'pastform))
	  ((Set-Equal Features '(Edparticiple))
	   (RETURN 'Edparticipleform))
	  ((Set-Equal Features '(Ingparticiple))
	   (RETURN 'Ingparticipleform))
	  ((Set-Equal Features '(Present-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Plural-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Stem))
	   (RETURN NIL))
	  ((Set-Equal Features '(Noun-Stem))
	   (RETURN NIL)) 
	  ((Set-Equal Features '(Past-form))
	   (RETURN 'Pastform))
	  ((Set-Equal Features '(Thirdperson-form Past-form)) ;; for cases where plurality
	   (RETURN 'Thirdsingularpastform ))                  ;; is not decided (Subj ellipsis)
	  ((Set-Equal Features '(Adj-neutral-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Superlative-form))
	   (RETURN 'superlativeform))
	  ((Set-Equal Features '(Comparative-form))
	   (RETURN 'comparativeform))
	  ((member (car features) 
		   '(pluralpastform verbpluralform 
		     thirdsingularform thirdsingularpastform 
		     firstsingularform))
	   ;this should take care of the FINITE case -rna
	   (return (car features))) 
	  (T 
           ;; following demoted to a caution... maybe we are just not doing a word that
           ;; needs to be inflected after all...
           (caution "No grammatical inflection features in feature set " grammatical-features 
                    ". Will use stem form of word.")
           NIL))))



;;;
;;; GERMAN
;;; ======
;;;

(defun GERMAN-GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE 
  (Grammatical-Features Noun-Flag)
  
  (PROG (features
	 (Valid-Grammatical-Inflection-Features 
	  '(Plural Singular Firstperson Secondperson Thirdperson 
		   Presentform Pastform Participle2 
		   Participle1 Stem
		   pluralpresentform
		   pluralpastform
		   verbpluralform
		   firstsingularpresentform
		   secondsingularpresentform
		   thirdsingularpresentform
		   secondpluralpresentform
		   singularpastform
		   secondsingularpastform
		   secondpluralpastform
		   )))
	(SETQ Features (remove-duplicates (intersection Grammatical-Features 
							Valid-Grammatical-Inflection-Features)))
	(SETQ Features (remove-duplicates Features))
	(cond
	  ((And Noun-Flag (Set-Equal Features '(Plural)))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Singular))
	   (RETURN NIL))
	  ((Set-Equal Features '(Firstperson Singular Presentform))
	   (RETURN 'Firstsingularpresentform))
	  ((Set-Equal Features '(Secondperson Singular Presentform))
	   (RETURN 'Secondsingularpresentform))
	  ((Set-Equal Features '(Thirdperson Singular Presentform))
	   (RETURN 'Thirdsingularpresentform))
	  ((Set-Equal Features '(Presentform Plural))
	   (RETURN 'Pluralpresentform))
	  ((Set-Equal Features '(Firstperson Presentform Plural))
	   (RETURN 'Pluralpresentform))
	  ((Set-Equal Features '(Secondperson Presentform Plural))
	   (RETURN 'Secondpluralpresentform))
	  ((Set-Equal Features '(Thirdperson Presentform Plural))
	   (RETURN 'Pluralpresentform))
	  ((Set-Equal Features '(Firstperson Singular Pastform))
  	   (RETURN 'Singularpastform))
	  ((Set-Equal Features '(Secondperson Singular Pastform))
	   (RETURN 'Secondsingularpastform))
	  ((Set-Equal Features '(Thirdperson Singular Pastform))
	   (RETURN 'Singularpastform))
	  ((Set-Equal Features '(Pastform Plural))
	   (RETURN 'Pluralpastform))
	  ((Set-Equal Features '(Participle2))
	   (RETURN 'Participle2form))
	  ((Set-Equal Features '(Participle1))
	   (RETURN 'Participle1form))
	  ((Set-Equal Features '(Presentform))
	   (RETURN NIL))
	  ((Set-Equal Features '(Plural))
	   (RETURN NIL))
	  ((Set-Equal Features '(Stem))
	   (RETURN NIL))
	  ((Set-Equal Features '(Pastform))
	   (RETURN 'Singularpastform))
	  ((member (car features) '(pluralpastform verbpluralform thirdsingularpresentform thirdsingularpastform firstsingularpresentform))
	   (return (car features))) ;this should take care of the FINITE case -rna
	  (T 
           ;; With the German grammar (KOMET March 94) fall through to the following so
           ;; often that it probably doesn't make sense to keep it as a warning!

           ;; (Warning "Improper grammatical inflection features " Features 
           ;;		      ". Will use stem form of word.")
           ;; 3.1 other grammars too, probably due to a change in design whereas most words come
           ;;     through this path now, not just those that are inflectable...
           NIL))))





;;;
;;; DUTCH
;;;

(defun DUTCH-GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE
  (grammatical-features noun-flag)
;;; 0.7.3 updated internal Dutch morphological feature mappings
  (PROG (features
	 (Valid-Grammatical-Inflection-Features 
	   '(Plural-form Singular-form Firstperson-form 
                    Secondperson-form Thirdperson-form 
		    Present-form Past-form Edparticiple 
		    Stem Noun-stem adj-neutral-form
		    )))
	(SETQ Features (remove-duplicates 
			 (intersection Grammatical-Features 
				       Valid-Grammatical-Inflection-Features)))
	(SETQ Features (remove-duplicates Features))
	(when *show-morphology-selection-flag*
	      (format t "~% ...Complete constraints from grammar: ~A" grammatical-features)
	      (format t "~% ...Morphology; constraints from grammar: ~A" features))
	(cond
	  ((And Noun-Flag (Set-Equal Features '(Plural-form)))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Singular-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Firstperson-form Singular-form Present-form))
	   (RETURN 'Firstsingularform))
	  ((Set-Equal Features '(Secondperson-form Singular-form Present-form))
	   (RETURN 'Secondsingularform))
	  ((Set-Equal Features '(Thirdperson-form Singular-form Present-form))
	   (RETURN 'Thirdsingularform))
	  ((Set-Equal Features '(Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Firstperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Secondperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Thirdperson-form Present-form Plural-form))
	   (RETURN 'Pluralform))
	  ((Set-Equal Features '(Firstperson-form Singular-form Past-form))
	   (RETURN 'Firstsingularpastform))
	  ((Set-Equal Features '(Secondperson-form Singular-form Past-form))
	   (RETURN 'Secondsingularpastform))
	  ((Set-Equal Features '(Thirdperson-form Singular-form Past-form))
	   (RETURN 'Singularpastform))
	  ((Set-Equal Features '(Thirdperson-form Plural-form Past-form))
	   (RETURN 'Pluralpastform))
	  ((Set-Equal Features '(Past-form Plural-form))
	   (RETURN 'Pluralpastform))
	  ((set-equal features '(present-form secondperson-form))
	   (return nil))
	  ((set-equal features '(past-form secondperson-form))
	   (return 'pastform))
	  ((Set-Equal Features '(Edparticiple))
	   (RETURN 'Edparticipleform))
	  ((Set-Equal Features '(Present-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Plural-form))
	   (RETURN NIL))
	  ((Set-Equal Features '(Stem))
	   (RETURN NIL))
	  ((Set-Equal Features '(Noun-Stem))
	   (RETURN NIL)) 
	  ((Set-Equal Features '(Past-form))
	   (RETURN 'Pastform))
	  ((Set-Equal Features '(Thirdperson-form Past-form)) ;; for cases where plurality
	   (RETURN 'Thirdsingularpastform ))                  ;; is not decided (Subj ellipsis)
	  ((Set-Equal Features '(Adj-neutral-form))
	   (RETURN NIL))
	  ((member (car features) '(pluralpastform verbpluralform thirdsingularform thirdsingularpastform firstsingularform))
	   (return (car features))) ;this should take care of the FINITE case -rna
	  (T (caution "Improper grammatical inflection features " Features 
		      ". Will use stem form of word.")
	     NIL))))





;;;====================================================================
;;; END of KOMET-PENMAN update




;;;
;;;  FRENCH
;;;  ------
;;;  (something trivial as a place holder....)

(defun FRENCH-GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE
  (grammatical-features noun-flag)
  (english-grammatical-features-to-lexical-feature
   grammatical-features noun-flag))


;;;
;;;  SPANISH
;;;  -------
;;;  from Alberto and Esperanza for the GUME project (UPM)....
;;;  added May 1998.
;;;  (with additions from 21-05-98 added in below)

(defun SPANISH-GRAMMATICAL-FEATURES-TO-LEXICAL-FEATURE
  (grammatical-features noun-flag)
  (PROG (features
         (Valid-Grammatical-Inflection-Features
          '( Plural-form
             Singular-form
             Masculine-form
             Feminine-form
             Firstperson-form
             Secondperson-form
             Thirdperson-form
             Present-form
             Past-form
             Edparticiple
             Ingparticiple
             Stem
             Noun-stem
             adj-neutral-form
             superlative-form
             comparative-form
             )))
    (SETQ Features (remove-duplicates
                    (intersection Grammatical-Features
                                  Valid-Grammatical-Inflection-Features)))
    (SETQ Features (remove-duplicates Features))
    (when *show-morphology-selection-flag*
      (format t "~% ...Complete constraints from grammar: ~A"
              grammatical-features)
      (format t "~% ...Morphology: constraints from grammar: ~A"
              features))
    (cond
     ((And Noun-Flag (Set-Equal Features '(Plural-form)))
      (RETURN 'Pluralform))
     ((Set-Equal Features '(Singular-form))
      (RETURN NIL))
     ;;; CONJUGACION DEL PRESENTE
     ((Set-Equal Features '(Firstperson-form Singular-form Present-form))
      (RETURN 'Firstsingularform))
     ((Set-Equal Features '(Secondperson-form Singular-form Present-form))
      (RETURN 'Secondsingularform))
     ((Set-Equal Features '(Thirdperson-form Singular-form Present-form))
      (RETURN 'Thirdsingularform))
     ((Set-Equal Features '(Firstperson-form Present-form Plural-form))
      (RETURN 'Firstpluralform))
     ((Set-Equal Features '(Secondperson-form Present-form Plural-form))
      (RETURN 'Secondpluralform))
     ((Set-Equal Features '(Thirdperson-form Present-form Plural-form))
      (RETURN 'Thirdpluralform))
     ;;; CONJUGACION DEL PASADO
     ((Set-Equal Features '(Firstperson-form Singular-form Past-form))
      (RETURN 'Firstsingularpastform))
     ((Set-Equal Features '(Secondperson-form Singular-form Past-form))
      (RETURN 'Secondsingularpastform))
     ((Set-Equal Features '(Thirdperson-form Singular-form Past-form))
      (RETURN 'Thirdsingularpastform))
     ((Set-Equal Features '(Thirdperson-form Plural-form Past-form))
      (RETURN 'Thirdpluralpastform))
     ;;; 0.9 added, since the grammar now tends to generate full paradigms
     ((Set-Equal Features '(Firstperson-form Past-form Plural-form))
      (RETURN 'Firstpluralpastform))
     ((Set-Equal Features ' (Secondperson-form Past-form Plural-form))
      (RETURN 'Secondpluralpastform))
     ;;;; se podrian borrar ?????
     ((Set-Equal Features '(Past-form Plural-form))
      (RETURN 'Pluralpastform))
     ((set-equal features '(present-form secondperson-form))
      (return nil))
     ((set-equal features '(past-form secondperson-form))
      (return 'pastform))
     ;;; participios
     ((set-equal features '(Edparticiple Feminine-form Plural-form))
      (RETURN 'Edfemininepluralform))
     ((set-equal features '(Edparticiple Feminine-form))
      (RETURN 'Edfeminineform))
     ((set-equal features '(Edparticiple Masculine-form Plural-form))
      (return 'Edmasculinepluralform))
     ((Set-Equal Features '(Edparticiple Masculine-form))
      (RETURN 'Edmasculineform))
     ((set-equal features '(Edparticiple Plural-form))
      (RETURN 'Edmasculinepluralform))
     ((set-equal features '(Edparticiple))
      (RETURN 'Edmasculineform))
     ((Set-Equal Features '(Ingparticiple))
      (RETURN 'Ingparticipleform))
     ((Set-Equal Features '(Present-form))
      (RETURN NIL))
     ((Set-Equal Features '(Stem))
      (RETURN NIL))
     ((Set-Equal Features '(Noun-Stem))
      (RETURN NIL))
     ((Set-Equal Features '(Past-form))
      (RETURN 'Pastform))
     ((Set-Equal Features '(Thirdperson-form Past-form)) ;; for cases where plurality
      (RETURN 'Thirdsingularpastform ))                  ;; is not decided (Subj ellipsis)
     ((Set-Equal Features '(Adj-neutral-form Feminine-form Plural-form))
      (RETURN 'pluralfeminineform ))
     ((Set-Equal Features '(Adj-neutral-form Feminine-form))
      (RETURN 'feminineform))
     ((Set-Equal Features '(Adj-neutral-form Masculine-form Plural-form))
      (RETURN 'pluralmasculineform))
     ((Set-Equal Features '(Adj-neutral-form Masculine-form))
      (RETURN NIL))
     ((Set-Equal Features '(Adj-neutral-form))
      (RETURN NIL))
     ((Set-Equal Features '(Comparative-form Feminine-form Plural-form))
      (RETURN 'pluralcompfeminineform ))
     ((Set-Equal Features '(Comparative-form Feminine-form))
      (RETURN 'femininecompform))
     ((Set-Equal Features '(Comparative-form Masculine-form Plural-form))
      (RETURN 'pluralcompmasculineform))
     ((Set-Equal Features '(Comparative-form Masculine-form))
      (RETURN 'masculinecompform))
     ((Set-Equal Features '(Superlative-form))
      (RETURN 'superlativeform))
     ((Set-Equal Features '(Comparative-form))
      (RETURN 'comparativeform))
     ((member (car features) 
              '(pluralpastform verbpluralform
                               thirdsingularform thirdsingularpastform firstsingularform))
      (return (car features))) ;this should take care of the FINITE case
     (T (caution "Improper grammatical inflection features " grammatical-Features
                 ". Will use stem form of word.")
        NIL))))

;;;----------------------------------------------------------------------
;;; Start of patch from Keith at ITRI.
;;; this needs to check for "a " rather than "a", 
;;;   at least in the one example I care about.  knvl
;;; now also hacked to change:
;;;   de le  --->  du;
;;;   de les  --->  des;
;;;   de un  --->  d'un;
;;;   de une  --->  d'une;
;;;   le/la * ---> l'*  (for words starting with a vowel or an h)
;;;
;;; ----------------------------------------------------------------------
;;; Following function performs a variety of `phonologically' induced
;;; changes which are not currently systemicized. For example
;;; English:
;;;  a -> an
;;;     assuming that "a" is always a "superc" of the noun
;;;     descend through the tree and change "a" to "an" if the next
;;;     word meets criteria in requires-an-an
;;;
;;; French:
;;; (from Keith at ITRI)
;;;   de le  --->  du;
;;;   de les  --->  des;
;;;   de un  --->  d'un;
;;;   de une  --->  d'une;
;;;   le/la * ---> l'*  (for words starting with a vowel or an h)
;;;
;;; The effects are produced by SIDE-EFFECTING the printable constituent
;;; structure given as argument. The function returns T.

;;; Incorporates:
;;; >0.7.16 fixed some spacing uglinesses and failure to recognise
;;;        indefinite articles. Complete patch is taken from Keith's
;;;        patch-file for 0.7 at ITRI.
;;;
;;; For the present, the inclusion of
;;; French graphological/phonological changes is also continued,
;;; although this entire area should get reworked `one of these
;;; days' to be more theoretically appropriate....
;;; >KPML 0.8: recognizes capital versions of vowels too.
;;;       2.0: changed to a method for cheap language conditionalization
;;;            and the individual contributions for English and French
;;;            that were contained in the function are broken out.
;;;            Base case now does nothing at all...

(defmethod PHONOLOGICAL-PROCESSING (printable-constituent curlan)
  "Effects `phonologically' induced changes such as >>>a<<< to >>>an<<<"
  
  (declare (special  printable-constituent-spelling-list-to-change 
		     previous-word this-word))
  t)

;;; Original Penman code for changes with Nigel broken out of the
;;; function PHONOLOGICAL-PROCESSING for a method just for English...
;;;
(defmethod PHONOLOGICAL-PROCESSING 
    (printable-constituent (curlan (eql :english)))
  "Effects `phonologically' induced changes such as >>>a<<< to >>>an<<<"
  (declare (special  printable-constituent-spelling-list-to-change 
		     previous-word this-word))
  (labels ((is-an-a (x)
		    (equal x "a "))   ;; HERE'S ONE CHANGE!
	   (requires-an-an (x)
	     (when (and x (stringp x))
	       ;; not perfect but close enough, 
	       ;; use exception list if necessary...
	       (member (elt x 0) 
		       '(#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)))) 
	   (requires-an-l (x)
	     (when (and x (stringp x))
	       (member (elt x 0) 
		       '(#\a #\e #\i #\o #\u #\h #\A #\E #\I #\O #\U #\H))))
	   (phonological-processing-0 
	       (x curent-printable-constituent-spelling )
	     (declare (special  
		       printable-constituent-spelling-list-to-change 
		       previous-word this-word))
	     (cond ((typep x 'printable-constituent)
		    (phonological-processing-0 
		     (printable-constituent-spelling x) 
		     (printable-constituent-spelling x)))
		   ((consp x )
		    (maplist 
		     #'(lambda (y)	;cdr down the list
			 (phonological-processing-0 (car y) y)) 
		     x))
		   (t

;(format t "the current spelling: ~s~%" 
;(car curent-printable-constituent-spelling))

		    (when (is-an-a x)
		      (setq printable-constituent-spelling-list-to-change
			;; save list that begins with "a"
			curent-printable-constituent-spelling )) 
		    (setq previous-word this-word)
		    (setq this-word x)

;;(format t "change?: ~s, ~s~%" previous-word this-word)

		    (when (and (is-an-a previous-word)
			       (requires-an-an this-word))

;;(format t "change to an: ~s" printable-constituent-spelling-list-to-change)

		      ;;; this list contain the "a" to be changed
		      (rplaca printable-constituent-spelling-list-to-change
			      "an "))
		   ))))
	  (setq previous-word nil)
	  (setq this-word nil)
	  (phonological-processing-0  printable-constituent nil)
	  t))


;;; Following is the ITRI code for French broken out of the original
;;; function PHONOLOGICAL-PROCESSING.
;;; With changes from Keith and Cecile from January 2000 in Sydney
;;; incorporated.
;;; Some oversights fixed by John + Cécile, January 2005 in Bremen.

(defmethod PHONOLOGICAL-PROCESSING 
    (printable-constituent (curlan (eql :french)))
  "Effects `phonologically' induced changes such as >>>de le<<< to >>>du<<<"
  (declare (special  printable-constituent-spelling-list-to-change 
		     previous-word this-word))
  (labels ( 
	   (requires-an-l (x)
	     (when (and x (stringp x))
	       (member (elt x 0) 
		       '(#\a #\e #\i #\o #\u #\h #\A #\E #\I #\O #\U #\H))))
	   (is-a-de (x)
		    (equal (string-trim " " x) "de"))  ; Added string-trim - cp/kvlinden, 17jan00
	   (is-a-le (x)
		    (equal (string-trim " " x)  "le"))
	   (is-a-la (x)
		    (equal (string-trim " " x) "la"))
	   (is-a-les (x)
		     (equal (string-trim " " x) "les"))
	   (is-an-un (x)
		     (equal (string-trim " " x) "un"))
	   (is-an-une (x)
		      (equal (string-trim " " x) "une"))
	   (phonological-processing-0 
	    (x curent-printable-constituent-spelling )
	    (declare (special  
		      printable-constituent-spelling-list-to-change 
		      previous-word this-word))
	    (cond ((typep x 'printable-constituent)
		   (phonological-processing-0 
		    (printable-constituent-spelling x) 
		    (printable-constituent-spelling x)))
		  ((consp x )
		   (maplist 
		    #'(lambda (y)  ;cdr down the list
			(phonological-processing-0 (car y) y)) 
		    x))
		  (t
		   ;;(format t "the current spelling: ~s~%" (car curent-printable-constituent-spelling))
		   (when (is-a-de x)
                     ;save list that begins with "de "
                     (setq printable-constituent-spelling-list-to-change
                           curent-printable-constituent-spelling )) 
		   (when (and (or (is-a-le x)
				  (is-a-la x))
			      (not (is-a-de this-word)))  ; I don't even want to know why this must be here!
			 (setq printable-constituent-spelling-list-to-change
			       curent-printable-constituent-spelling )) ;save list that begins with "le " or "la "
		   (setq previous-word this-word)
		   (setq this-word  x)
		   ;;(format t "change?: ~s, ~s~%" previous-word this-word)
		   ;;
		   ;; a VERY hacky solution to the de-le and de-les problem!!!
		   (when (is-a-de previous-word)
			 (when (is-a-le this-word)
			       ;;(format t "change to du: ~s" (printable-constituent-spelling x))
			       (rplaca printable-constituent-spelling-list-to-change "du ") ;changes previous word
			       (setf (car curent-printable-constituent-spelling) "")) ;changes current word
			 (when (is-a-les this-word)
			       ;;(format t "change to des: ~s" (printable-constituent-spelling x))
			       (rplaca printable-constituent-spelling-list-to-change "des ")
			       (setf (car curent-printable-constituent-spelling) ""))
			 (when (is-an-un this-word)
			       ;;(format t "change to d'un: ~s" (printable-constituent-spelling x))
			       (rplaca printable-constituent-spelling-list-to-change "d'un ")
			       (setf (car curent-printable-constituent-spelling) ""))
			 (when (is-an-une this-word)
			       ;;(format t "change to d'une: ~s" (printable-constituent-spelling x))
			       (rplaca printable-constituent-spelling-list-to-change "d'une ")
			       (setf (car curent-printable-constituent-spelling) ""))
			 (when (requires-an-l this-word)
			       ;; 4.0 added by John + Cécile, Bremen, Jan 2005
			       ;;(format t "change to d'V: ~s" (printable-constituent-spelling x))
			       (rplaca printable-constituent-spelling-list-to-change "d'")
			       ;;(setf (car curent-printable-constituent-spelling) "")
			       )
			 )
		   (when (and (or (is-a-le previous-word)
				  (is-a-la previous-word))
			      (requires-an-l this-word))
			 ;;(format t "previous: ~s  this: ~s~%" previous-word this-word)
			 ;;(format t "change to l': ~s" printable-constituent-spelling-list-to-change)
			 (rplaca printable-constituent-spelling-list-to-change "l'"))
		   ))))
	  (setq previous-word nil)
	  (setq this-word nil)
	  (phonological-processing-0  printable-constituent nil)
	  t))


;;; 2.0 additional method for Spanish as requested by Alberto and Esperanza
;;;     for generation in GUME project. Is active when curlan is :spanish.
;;;     (and for GUME-ENGLISH as that is what that resource is currently 
;;;     called).

(defmethod PHONOLOGICAL-PROCESSING 
    (printable-constituent (curlan (eql :gume-english)))
  (phonological-processing printable-constituent :spanish))

(defmethod PHONOLOGICAL-PROCESSING 
    (printable-constituent (curlan (eql :spanish)))
  "Effects `phonologically' induced changes such as >>>a el<<< to >>>al<<<"
  (declare (special  printable-constituent-spelling-list-to-change 
		     previous-word this-word))
  (labels ( 
	   (is-a-a (x)                  ;; predicates for recognizing
		    (equal x "a "))     ;; the words we want to change...
	   (is-a-el (x)
		    (equal x "el "))
	   (is-a-de (x)
		    (equal x "de "))
           (is-a-y (x)
                   (equal x "y "))
           (is-a-o (x)
                   (equal x "o "))
	   
	   ;; function for the changes in situ in the constituent
	   ;; structure...
	   ;;
	   (phonological-processing-0 
	       (x curent-printable-constituent-spelling )
	    (declare (special  
		      printable-constituent-spelling-list-to-change 
		      previous-word this-word))
	    (cond ((typep x 'printable-constituent)
		   (phonological-processing-0 
		    (printable-constituent-spelling x) 
		    (printable-constituent-spelling x)))
		  ((consp x )
		   (maplist 
		    #'(lambda (y)  ;cdr down the list
			(phonological-processing-0 (car y) y)) 
		    x))
		  (t
                   (when (or (is-a-de x)
                             (is-a-a x))
                     ;; save list that begins with de or a
                     (setq printable-constituent-spelling-list-to-change
                           curent-printable-constituent-spelling))

		   (setq previous-word this-word)
		   (setq this-word x)
		   ;;(format t "change?: ~s, ~s~%" previous-word this-word)

		   ;; a VERY hacky solution to the de-le and de-les problem!!!
		   ;; adapted as a presumably equably hacky solution for the
		   ;; Spanish! 
		   (when (is-a-de previous-word)
                     (when (is-a-el this-word)
                       (rplaca printable-constituent-spelling-list-to-change 
                               "del")   ;changes previous word
                       (setf (car curent-printable-constituent-spelling) 
			     ""))	;changes current word
                     )
		   (when (is-a-a previous-word)
                     (when (is-a-el this-word)
                       (rplaca 
                        printable-constituent-spelling-list-to-change 
                        "al")	;changes previous word
                       (setf (car curent-printable-constituent-spelling) 
			     ""))	;changes current word
                     )
                   (when (is-a-o previous-word)
                     ;; "o" +"o..." --> "u" + "o..."
                     ;;  "o" +"ho..." --> "u" + "ho..."
                     (when (or (and (> (length this-word) 0)           ;; be very cautious!
                                    (char= (char this-word 0) #\o))
                               (and (> (length this-word) 1)
                                    (string= (subseq this-word  0 2) "ho")))
                       (rplaca 
                        printable-constituent-spelling-list-to-change 
                        "u") ; changes previous word, current word unchanged...
                       ))
                   (when (is-a-y previous-word)
                     ;; "y" + "hi..." = "e" +"hi..."
                     ;; "y" + "i..."  = "e" + "i.."
                     (when (or (and (> (length this-word) 0)
                                    (char= (char this-word 0) #\i))
                               (and (> (length this-word) 1)
                                    (string= (subseq this-word  0 2) "hi")))
                       (rplaca 
                        printable-constituent-spelling-list-to-change 
                        "e")))
		   ))))
    ;; initialize and go...
    (setq previous-word nil)
    (setq this-word nil)
    (phonological-processing-0 printable-constituent nil)
    t))

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

;;; changes needed to get rid of extra spaces.  Sometimes, the strings
;;; do not have a trailing blank, in which case there is an explicit
;;; string with a blank separating the string from the next word;
;;; sometimes, however, there is one trailing blank.  when there is no
;;; trailing blank and the next string is not an explicit blank, it
;;; indicates that the next string is an inflectional ending. Thus NO
;;; blank shoudl be inserted there.  Problems: (1) sometimes there are
;;; several explicit blank strings ==> we get too many blanks.  (2)
;;; sometimes there are more than 1 trailing blank ==> we get too many
;;; spaces again.

;;;  I fixed it in the following way:
;;; for (1): When I encounter an explicit blank, I "remember" it. If the next
;;;  string is also an explicit blank, it is ignored.
;;; for (2): I  strip all trailing blanks of a string: if the resulting
;;; string is identical to the original one, I just return the string,
;;; as it means that there were no blanks at all (and thus is either
;;; the stem of a word that needs to be inflectify, or there is an
;;; explicit blank string afterwards).
;;; If the two strings are not equal, than this means that there were
;;; more than 1 trailing blank. I add one back (so we only have *1*
;;; trailing blank).

(defun UNIFY-STRING (list-string)
  (let ((result "")(first-word t) (previous-string-is-blank nil))
  (dolist (x list-string)
    (cond ((equal x "")
	   (setq previous-string-is-blank nil))				;don't include null words
	  ((equal x " ") 
	   (cond ((not previous-string-is-blank) 
		  (setq result (concat result (string x)))
		  (setq previous-string-is-blank t))))
	  ((equal x "'s")
	   (setq previous-string-is-blank nil)
	   (setq result (concat result (string x)))) ;no space for possesion marker 's
	  ((or (equal x ",")(equal x ".")(equal x "?")(equal x "!"))
	   (setq previous-string-is-blank nil)
	   (setq result (concat result (string x) " "))) ;***no space for punctuation...
	  (first-word
	   (setq result (build-string-with-one-blank-consistently (string x)))
	   (setf first-word nil))
	  (T
	   (setq previous-string-is-blank nil)
	   (setf result
	     (if *activate-word-rank-and-below* 
		 (setq result (concat result 
				      (build-string-with-one-blank-consistently
				       (string x))))
	       (SETQ result (CONCAT result " " (string x)))
	       )))
	  ))
  result))


;;; if there are trailing blanks, makes sure there is only *1*

(defun BUILD-STRING-WITH-ONE-BLANK-CONSISTENTLY (string)
  (cond ((equal string (strip-blanks string)) ; there were no blanks
					      ; ==> morphology or
					      ; explicit blank string afterwards
	 
	 string)
	(T (add-one-blank (strip-blanks string)))))


(defun STRIP-BLANKS (string)
  (string-trim '(#\Space) string))

(defun ADD-ONE-BLANK (string)
  (concat string " "))


;;; End of graphological processing patches from ITRI.
;;;-----------------------------------------------------------------
 
;; Implement string-substitute using search and replace

(defun string-substitute (new old string &key count)
  (if (and (numberp count)
	   (<= count 0))
      string
      (let ((start (search old string))
	    (old-len (length old))
	    (new-len (length new)))
	(do ((i 1 (1+ i))) ((not start) string)
	  (if (= new-len old-len)
	      (replace string new :start1 start :end1 (+ start old-len))
	      (setq string (concatenate 'string
					(subseq string 0 start)
					new
					(subseq string (+ start old-len)))))
	  (setq start (when (or (not count)
				(< i count))
			(search old string :start2 (+ start new-len))))))))

(defun replace& (str)
   (string-substitute "and" "&" (string-substitute "," " &" str :count (1- (count #\& str))))
)

;;; Note: should
;;; not do this kind of hackery in code.... (also relied on the
;;; null character that ACL3.0 does not like). But, kept for the
;;; time being (conditionalized)...

(defun remove-spaces-between-numerals-and-compass-points (string)
  "Remove spaces between numerals and compass points"
  (mark-spaces-to-remove string)
  #-(and aclpc acl3.0)(delete #\null string)
  string)

(defun mark-spaces-to-remove (string)
  "Mark with null characters all spaces between numerals and compass points."
  #-(and aclpc acl3.0)
  (do ((pos 0 (+ pos 1))
       (end  (length string)))
      ((= pos end))
    (when (mark-space-p string pos)
      (setf (elt string pos) #\null)))
  #+(and aclpc acl3.0) string)

(defun mark-space-p (string position-of-space)
  "If the space at  position-of-space in string is surrounded by numbers or compass points return t, else nil"
  (when (null position-of-space)
    (return-from mark-space-p nil))
  (unless (equal (elt string  position-of-space) #\space)
      (return-from mark-space-p nil))
  (let ((last-char-position (- (length string) 1)))
    (when (equal  position-of-space 0)
      (return-from mark-space-p nil))
    (when (equal position-of-space last-char-position)
      (return-from mark-space-p nil))
    (let ((left-char (elt string (- position-of-space 1)))
	  (right-char (elt string (+ position-of-space 1))))
      (when (and (numeral-p left-char)
		 (numeral-p right-char))
	(return-from mark-space-p t))
      (when (and (compass-point-p left-char)
		 (compass-point-p right-char))
	(return-from mark-space-p t))
      (when (and (numeral-p left-char)          ;this will get extranious stuff, replace
		 (compass-point-p right-char))
	(return-from mark-space-p t))
      )))

(defun numeral-p (char)
  (if (member char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
      t
      nil))

(defun compass-point-p (char)
  (if (member char '(#\N #\S #\E #\W))
      t
      nil))


;;; Changes to Penman91 handling of morphology --- John: IPSI: Dec 1991.
;;;=====================================================================
;;;
;;;              Updates: 92, 94.
;;;
;;; '95: KPML 0.9, some bookkeeping wrt old-features added...

;;;
;;; In this  file we replace  the hardcoded morphology of the original
;;; penman system with system networks for word and morpheme rank. The
;;; traversal algorithm is  altered  in as far  as  whereas inflectify
;;; realization    statements in  the  grammar  would  previously have
;;; controlled the hardwired selection of morphological form, they are
;;; now converted  to preselections and control  is passed back to the
;;; grammar. Inflectify features should be defined features under word
;;; or morpheme. Different languages can  now define their own regular
;;; and  irregular   morphologies in standard  network  form: however,
;;; there will need  to  be  some  work  on what kind  of  realization
;;; statements are  appropriate  for  these ranks.   These realization
;;; statements  need in the  longer  term to handle the  inter-stratum
;;; mapping  down to graphology/phonology,  but   for now  we  operate
;;; directly  on  spellings. 

;;; (A further    small change is made  to   the  traversal algorithm:
;;; previously, if there was   no chooser or  defaultchoice specified,
;;; then the algorithm would insist that the user express some opinion
;;; about the feature to be selected, even if  there is a preselection
;;; --- this is  changed so  that if a   preselection holds, this   is
;;; sufficient for making a choice --- cf. function: Select-Major.)

;;; In versions of English resources for 1995 (KPML resources, release
;;; 2 and up), clashes between lexical features (used in classifies) 
;;; and grammatical features have also been removed. A function for
;;; doing this automatically is given at the end of this file.

;;;----------------------------------------------------------------------
;;; The following describes the changes that need to be made to
;;; a version of Nigel that does not already include changes made
;;; for compatibility with word and morpheme rank systems.
;;;
;;;     To  incorporate   morphology  and   word  rank    systems, and
;;;     nevertheless  to be able to use existing lexicon entries
;;;     and to maintain compatibility with existing resources, the
;;;     following needs to be done.

;;; (1) Since inflectify  features  become  normal   lexicogrammatical
;;;     features, they must not  overlap with existing  features. This
;;;     is not the case with the standard
;;;     Penman91 version of Nigel and so must be enforced.

;;; Action: all inflection features that   were ambiguous are  altered
;;;          so that they end  with the string "-form".  This must
;;;          be done  for  all  inflectifies  in the   grammar  files;
;;;          inflectify features  should not  appear in the `features'
;;;          list   of   lexical entries,  only    in the `properties'
;;;          list. The  regions  where  inflectifies requiring changes
;;;          occur  in   the  Penman91    version   of  Nigel     are:
;;;          (ADJECTIVAL-COMPARISON     TENSE  COUNTNUMBER  TAG   MOOD
;;;          UNIFYINGGATES ELLIPSIS).

;;;     In MOOD, we   also  change  features such  as   FIRSTPERSON to
;;;     firstperson-form.  Also, there are inflectifies for STEM, this
;;;     is not  specific enough, and  so needs  to  be changed to  the
;;;     appropriate morphological feature as shown below:

;;;      ADJECTIVAL-COMPARISON: (inflectify quality stem) 
;;;                                                --> adj-neutral-form
;;;      CLASSIFICATION: (inflectify classifier* stem)    --> noun-stem
;;;      COUNTNUMBER: (inflectify thing stem)             --> noun-stem
;;;      NOUNTYPE:  (inflectify thing stem)               --> noun-stem
;;;      DETERMINATION: (inflectify thing stem)           --> noun-stem

;;;     Note  that some  of  the  work  previously done  by classified
;;;     (e.g.,     classify X  noun)        should now  be   done   by
;;;     inflectifies/preselects.  Particular   cases  are   in  region
;;;     ELLIPSIS.
 
;;; ***  THESE  CHANGES HAVE  ALREADY   BEEN MADE IN  REGION-BY-REGION
;;; VERSIONS OF NIGEL PRODUCED IN APRIL 92 OR AFTER. ***

;;; (2) Make sure  none   of these `composite' inflectify    features:
;;; (Firstsingularpastform                      Secondsingularpastform
;;; Thirdsingularpastform Pluralpastform) occur in inflectifies in the
;;; defined grammar (they don't in the Penman91 version of Nigel).

;;; (3) The lexical entries themselves need not be changed, as long as
;;;     the  "-form" is also appended to  the list at the beginning of
;;;     the function  GRAMMATICAL-FEATURE-TO-LEXICON-FEATURE   in  the
;;;     file  systemic-networks/boards.lisp (a ready converted version
;;;     is appended below).  This acts as a translation procedure from
;;;     the inflection  features as they  appear in the grammar to the
;;;     single combined features that  appear in the property lists of
;;;     lexical   items. Changing this  function  will ensure that the
;;;     relevant  properties will  still   be  found in  the   lexical
;;;     entries, even though the inflectify features have changed.

;;; (4)  Finally, note that several  functions in  the files allparts,
;;;      traversal, and boards are  changed here --- although normally
;;;      in small ways. When adding  this  functionality to other
;;;      Penman  variants, it is  therefore necessary to make sure
;;;      that other locally  defined versions of the the functions
;;;      are  *augmented*  rather  than  *overwritten*. 

;;;====================================================================


;;;====================================================================
;;; Immune system  defusing... i.e., make  Penman happy about  the new
;;; varieties of realization operators and chooser actions...

(define-realization-operators preselect-substance weaken strengthen chop)
(setf legal-extension (append legal-extension '(preselect-substance)))

;;;---------------------------------------------------------------------
;;; also need to help the graphology out so that  it knows when to put
;;; spaces...  NOTE: THIS SHOULD BE CHANGED SO THAT IT IS A FEATURE OF
;;; THE INDIVIDUAL LANGUAGES  THAT ARE  DEALT WITH....  added  already
;;; into KOMET-PENMAN punctuation.gram....

(defvar *word-separator* " ")

;;; ============================================================
;;; Following function is called only when there is a potential
;;; word rank traversal but the resources as defined have not
;;; specified any constraints for that traversal. 
;;; 2.0 gives some more detailed warnings about lack of constraints just
;;;     when there is no realization established.
;;;
(defun GET-CLASSIFIED-LEXEME (arg)
  (let* ((constraint-type (whiteboard-elt-id arg))
	 (fundle-id (whiteboard-elt-aliasfn arg))
	 (realization (first (whiteboard-elt-realization arg)))
	 (form 
	  (if realization
	      (fetch-lexicon-info realization 'spelling)
	    "<unrealized lexeme>"))
	 (word-sep? (assoc 'words (ml-post-self-punctuation))))
    (unless (consp (whiteboard-elt-realization arg))
      (warning 
       "Constituent " fundle-id
       " has no word rank or below constraints! "
       "Missing inflectifies/preselects in resources.")
      (unless (eq constraint-type 'classify)
	(warning "Constituent" fundle-id " not even classified!")))
    (if word-sep?
	(concatenate 'string form (third word-sep?))
      form)))

;;;======================================================================
;;;
;;; KEEPING IRREGULAR ENTRIES IN LEXICON...
;;;
;;; It is still necessary and/or  useful to have irregular  morphology
;;; appearing in a lexical specification in a lexicon. So, rather than
;;; directly entering  word  rank, if it   is possible to  pull out  a
;;; directly specified  irregular form from the  property lists of the
;;; lexical entry, then we take this  as the final realization, rather
;;; than  constructing one. This is achieved  by  a revised version of
;;; realize-inflectify,  which  checks for  existence  of an irregular
;;; realization, rather than constructing a string regardless.

;;; Patch 0.7.4
;;; Dutch resources use the following feature in their lexical
;;; entries...

(push 'strong *lexical-entry-ending-types*)
(push 'strong *lexicon-irregular-ending-types*)

;;;======================================================================
;;; PREPARATION OF FINAL PRINT STRING used to be here, now more appropriately
;;; separated out to generation-results.lisp, parameterized and made
;;; user accessible.
;;;======================================================================

;;; ----------------------------------------------------------------------
;;; Some morphology/punctuation methods...
;;; 

;; Serge Sharoff, University of Bielefeld (Dec 2001)
;; a simple implementation of the preposition-article merge in German
;; (John: slight modification to ignore the number of spaces around the
;;        the strings)
;; incorporated as patch KPML 3.2.65
;; ----------------------------------------------------------------------

(defun FIRST-PRINTABLE-CONSTITUENT-WITH-SPELLING (prep-obj)
  (let ((first-const (printable-constituent-spelling prep-obj)))
    (if (stringp (first first-const))
        first-const
        (first-printable-constituent-with-spelling (first first-const)))))

(defun PREPOSITION-MERGE-DE (wol)
 (if (null (second wol)) wol
   (let* ((minorprocess (first wol))
          (preposition 
	   (string-trim '(#\space) 
			(first (printable-constituent-spelling minorprocess))))
          (prep-obj (second wol))
          (first-word-string 	   
	   (string-trim '(#\space) 
			(first (first-printable-constituent-with-spelling prep-obj)))))
     (print preposition)
     (cond ((and (string= preposition "zu") (string= first-word-string "der"))
	     (setf (first (printable-constituent-spelling minorprocess)) "zur")
     	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "zu") (string= first-word-string "dem")) 
	     (setf (first (printable-constituent-spelling minorprocess)) "zum")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "an") (string= first-word-string "dem"))
	     (setf (first (printable-constituent-spelling minorprocess)) "am")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "bei") (string= first-word-string "dem"))
	     (setf (first (printable-constituent-spelling minorprocess)) "beim")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "in") (string= first-word-string "das"))
	     (setf (first (printable-constituent-spelling minorprocess)) "ins")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "in") (string= first-word-string "dem"))
	     (setf (first (printable-constituent-spelling minorprocess)) "im")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " "))
          ((and (string= preposition "von") (string= first-word-string "dem"))
	     (setf (first (printable-constituent-spelling minorprocess)) "vom")
	     (setf (first (first-printable-constituent-with-spelling prep-obj)) " ")))
    wol)))

