(in-package "KPML")

;;; File: lexemes.lisp
;;; 
;;; Contains definition of the linguistic object: lexical item.
;;;
;;;
; 2.0  Note: lexical items are not being picked up as patched...
;       and so are excluded for the time being from versioning.
;       This is probably an oversight rather than plan.
; 4.0  Added gloss and translit slots for maintaining information
;       of different forms simultaneously.
;      Made gloss default to the name if not given explicitly
;      Made clisp-free.

(defstruct LEXICAL-ITEM
 (name nil :type list)
 (spelling "" :type (or string list))
 (sample-sentence "" :type (or string list))
 (features nil :type list)
 (properties nil :type list)
 (stem "" :type (or string list))         ;; added for morphology
 (gloss "" :type (or string list))        ;; 4.0  for glosses
 (translit "" :type (or string list))     ;; 4.0  for different character sets
 (comments "" :type (or string list))
 (editor "" :type (or string list))
 (date "" :type (or string list))
 (semantics nil :type list)
 (LS-set nil :type list)                    ;; added for multilinguality
 (source-file nil :type (or pathname list)) ;; added for resource management
)

;;; ----------------------------------------------------------------------
;;; User access and some filtering functions moved here from term-resolve
;;; where they are no longer used in any case (John:Feb98).

(defmacro LEXICAL-ITEM (&rest body)
  `(load-ml-lexicon ',body))

(defun LIST-LEXICAL-ITEMS (&optional (lg nil))
  (if lg
      (filter-terms-by-language (hashtable-to-list lexicon) lg)
    (hashtable-to-list lexicon)))

(defun FILTER-TERMS-BY-LANGUAGE (termset lg)
  (remove 'nil
   (mapcar #'(lambda (item) (if (lexeme-defined-for-lg-p item lg) item nil))
	   termset)))

(defun FILTER-TERMS-BY-LANGUAGES (termset languages)
  (remove 'nil
   (mapcar #'(lambda (item)
	       (if (loop for lg in languages
		       thereis (lexeme-defined-for-lg-p item lg))
		   item
		 nil))
	   termset)))

;;; ----------------------------------------------------------------------
;;; Management functions...

(defun FETCH-LEXICON-INFO (lex-name fld-name &optional ls)
  (let* ((x (gethash lex-name lexicon))
         (y nil))
    
    (unless x (return-from fetch-lexicon-info nil))
    (setf y (copy-lexical-item x))
    (unless ls (setq ls CurLan))
    (when (eq fld-name 'ls-set)
	  (return-from fetch-lexicon-info (lexical-item-ls-set x)))
    (if (and ls (not (member ls (lexical-item-LS-set X))))
        (return-from fetch-lexicon-info nil))

    (case fld-name
      ((everything instance) 
       (if ls
	   (block nil
	     (setf (lexical-item-spelling y) 
		   (strip-LX (parse-clause (lexical-item-spelling y) ls)))
	     (setf (lexical-item-features y)
		   (parse-clause (lexical-item-features y) ls))
	     (setf (lexical-item-properties y)
		   (parse-clause (lexical-item-properties y) ls))
	     (setf (lexical-item-semantics X)
		   (parse-clause (lexical-item-semantics y) ls))
	     (setf (lexical-item-stem X)
		   (strip-ml (lexical-item-stem y) ls))
	     (setf (lexical-item-gloss X)
		   (strip-ml (lexical-item-gloss y) ls))
	     (setf (lexical-item-translit X)
		   (strip-ml (lexical-item-translit y) ls))
;;; 0.8 added...
	     (setf (lexical-item-sample-sentence X)
		   (strip-ml (lexical-item-sample-sentence y) ls))
	     (setf (lexical-item-comments X)
		   (strip-ml (lexical-item-comments y) ls))
	     (setf (lexical-item-source-file X)
		   (strip-ml (lexical-item-source-file y) ls))
	     (return-from fetch-lexicon-info y)
	     )
	     Y))
                                    
      (name        (if ls (strip-ml (lexical-item-name X) ls)
		     (lexical-item-name X)))
      (spelling    (if ls (strip-LX (parse-clause (lexical-item-spelling X) ls))
                       (lexical-item-spelling X)))
      (features    (if ls  (parse-clause (lexical-item-features X) ls)
                       (lexical-item-features X)))
      (properties  (if ls (parse-clause (lexical-item-properties X) ls)
                       (lexical-item-properties X)))
      (semantics   (if ls (parse-clause (lexical-item-semantics X) ls)
                       (lexical-item-semantics X)))
;;; stem added...John Oct92
      (stem       (if ls (strip-ml (lexical-item-stem X) ls)
                       (lexical-item-stem X)))

;;; gloss and translit added...John Oct2002
      (gloss       (if ls (strip-ml (lexical-item-gloss X) ls)
		     (lexical-item-gloss X)))
      (translit    (if ls (strip-ml (lexical-item-translit X) ls)
		     (lexical-item-translit X)))

;;; multilingualized...John Apr95.
      (sample-sentence (if ls (strip-ml (lexical-item-sample-sentence X) ls)
			 (lexical-item-sample-sentence X)))
      (comments        (if ls (strip-ml (lexical-item-comments X) ls)
			 (lexical-item-comments X)))
      (date       (if ls (strip-ml (lexical-item-date X) ls)
		    (lexical-item-date X)))
      (editor     (if ls (strip-ml (lexical-item-editor X) ls)
		    (lexical-item-editor X)))
      (source-file (if ls (strip-ml (lexical-item-source-file X) ls)
		     (lexical-item-source-file X)))
      )
))

;;; 2.0
;;; Also provide the following extra for easing access to external
;;; lexicons...

(defmethod FETCH-LEXICON-FEATURES (lex-entry curlan)
  (fetch-lexicon-info lex-entry 'features curlan))

;--------------------------------------------------------------------------
; SYNTAX: fetch-ftr-lex-assoc (feature-id, &optional ls)
; RETURN: a list of lexical items associated with feature-id under the language environmen ls;
; TARGET: as name indicates;
; ASSUME: DB struct = ftr-lex-assoc, that is, (ls lex1...lexn)
; GLOBAL: DB = words-of-a-feature;
; SYMBOL:
; PSEUDO: find feature-id in DB, if no find, return nil else lex is instantiated;
;         if LS=nil then LS=CurLan; if LS still nil, LS = whole languages, return Lex;
;         find ls in Lex, if found return lexical list; else return nil;
;--------------------------------------------------------------------------------------------------

(defun FETCH-FTR-LEX-ASSOC (ftr &optional ls)
  (let ((LexLst (gethash ftr words-of-a-feature)))
    (unless LexLst (return-from fetch-ftr-lex-assoc nil))
    (unless ls (setq ls CurLan))
    (unless ls (return-from fetch-ftr-lex-assoc LexLst))
    (return-from fetch-ftr-lex-assoc (cdr (assoc ls LexLst)))
))



;--------------------------------------------------------------------------------------------------
; SYNTAX: replace-ftr-lex-assoc (feature-id, new-lex, &optional ls)
; RETURN: side effect: lexical items associated with feature-id under the language environment are
;         replaced by new-lex;
; TARGET: as name;
; ASSUME: DB struct = ftr-lex-assoc, that is, (ls lex1...lexn);
;         if feature-id is not found in DB, no new entries will be created.
; GLOBAL: DB = words-of-a-feature;
; SYMBOL:
; PSEUDO: find feature-id in DB, if no find, return nil else lex is instantiated;
;         if LS=nil then LS=CurLan; if LS still nil, LS = whole languages, replace Lex with new-lex;
;         find ls in Lex, if found then replace (ls lex1...lexn) with (ls new-lex); 
;                         else add in (ls new-lex);
;--------------------------------------------------------------------------------------------------
    
(defun replace-ftr-lex-assoc (ftr new-lex &optional ls)
  (let ((LexLst (gethash ftr words-of-a-feature)) ptr)

    (unless LexLst (return-from replace-ftr-lex-assoc nil))
    (unless ls (setq ls CurLan))
    (unless ls (return-from replace-ftr-lex-assoc (setf (gethash ftr words-of-a-feature) new-lex)))

    (if (setf ptr (assoc ls LexLst))
        (rplacd ptr new-lex)
        (push  new-lex LexLst))
))


(defsetf fetch-ftr-lex-assoc (ftr &optional LS) (new-lex) 
  `(replace-ftr-lex-assoc ,ftr ,new-lex ,LS) )


;--------------------------------------------------------------------------------------------------
; SYNTAX: precompile-LexFtr (LexFeature-list, Lex-id)
; RETURN: side effect that language-sensitive (LexFeature, LS, Lex-id) pairs are added into
;         words-of-a-feature DB;
; TARGET: register (LexFeature, LS, Lex-id) pairs in the DB;
; ASSUME: LexFeature-list of the format: ((F1, L1...Ln) ... (Fn, L1'...Ln'))
;         Lex-id of the format: (Lex-id, Lang1...Langn)
; GLOBAL: DB = words-of-a-feature;
; SYMBOL: ValidLs = valid language specifiers for a feature; 
;         LS = a language specifer in ValidLS; 
;         entryLS = the language specifiers attached to the Lex;
;         Lex = a lexical item;
;         LexFtr = lexical feature;
;         DB-ptr = an entry in DB of the structure (LexFeature, LS, Lex-id);
; PSEUDO: for each feature in lexftr-list do
;             find if DB already records this feature;
;             update the DB with (ftr, LS, lex) triple according to different situation.
;--------------------------------------------------------------------------------------------------

(defun precompile-lexftr (lexftr-list lex-id)
  (let ((lex (car lex-id)) (entryLS (cdr lex-id))
        ValidLs LexFtr DB-ptr Ftr-Lex-Lnk)

    (loop for eachone in lexftr-list do

         (setq LexFtr (car eachone))
         (setq ValidLs (intersection entryLS (cdr eachone)))
                              ; set up variables
         (setf DB-ptr (gethash LexFtr words-of-a-feature))
                              ; fetch DB to see if a feature has already registered there;
         (loop for eachLS in validLS do
              (if (setf Ftr-Lex-Lnk (assoc eachLS DB-ptr))
                (pushnew lex (cdr Ftr-Lex-Lnk))
                (push (cons eachLS (list lex)) (gethash LexFtr words-of-a-feature) )
                              ; if already registered, and a LS already registered too, then
                              ; merely add in the new lex to existing (LS lex) pair
                              ; else add in the (LS Lex) pair to DB; Notice the trick of 
                              ; (push X (gethash Y DB)) here. If DB entry exists, it only pushes
                              ; a new (LS lex) pair; if DB does not exist, it first create a dummy
                              ; record in DB and later push a (LS lex) pair into it.
                  ) ; if
              ) ; for
         ) ;for
    ))

;--------------------------------------------------------------------------------------------------
; SYNTAX: replace-lexicon-info (lexicon-name, field-name, new-value, &optional ls)
; RETURN: the replaced value of the specified field in the lexicon; the field of the lexicon record
;         is changed to new value;
; TARGET: as indicated;
; ASSUME: due to the complexity of modifying LX expression, we assume that new-value is a LX. Hence
;         ls does not play any role. We simply replace the field with the whole new-value. This func
;         will not create new lexicon when the given lexicon name is not found in the database;
; GLOBAL: ALL_LANGUAGES; lexicons;
; SYMBOL: X = an instance from lexicon DB;
; PSEUDO: if lexicon-name not in lexicons, then return nil else X is instantiated; 
;         according to field-name, return(replace (lexicon-field-name X) with the new-value);
;--------------------------------------------------------------------------------------------------

(defun replace-lexicon-info (lex-name fld-name new-value &optional ls)
  (let ((x (gethash lex-name lexicon)))
    (declare (ignore ls))
    (unless x (return-from replace-lexicon-info nil))
  
  (case fld-name
      (name            (setf (lexical-item-name X) new-value))
      (spelling        (setf (lexical-item-spelling X) new-value))
      (features        (setf (lexical-item-features X) new-value))
      (properties      (setf (lexical-item-properties X) new-value))
      (source-file     (setf (lexical-item-source-file X) new-value))
      (semantics       (setf (lexical-item-semantics X) new-value))
      (sample-sentence (setf (lexical-item-sample-sentence X) new-value))
      (comments        (setf (lexical-item-comments X) new-value))
      (date            (setf (lexical-item-date X) new-value))
      (editor          (setf (lexical-item-editor X) new-value))
      (LS-set          (setf (lexical-item-LS-set X) new-value))
 
      )
))

(defsetf fetch-lexicon-info (lex-name fld-name &optional LS) (new-value) 
  `(replace-lexicon-info ,lex-name ,fld-name ,new-value ,LS) )

;;; ----------------------------------------------------------------------
;;; Loading...

(defun LOAD-ML-LEXICON (body)		
  (let* ((lex-def (apply #'make-lexical-item body))
	 NameLst
	 LexFtr-lst
	 )

    ;;     Check the validity of lexical definition (not defined)
    ;;     (unless (lexical-def-valid lex-def)  
    ;;	     (return-from load-ml-lexicon nil))

     (setf LexFtr-lst (get-atom-ls (lexical-item-features lex-def)))

     ;; 0.7.29 fix combination of defaults and explicit conditionalizations.
     ;;
     (when (symbolp (lexical-item-name lex-def))
	   (setf (lexical-item-name lex-def)
		 (append 
		  (cond 
		   (*current-default-languages*
		    (check-language-availability *current-default-languages*)
		    *current-default-languages*)
		   (t  all_languages))
		  (cons (lexical-item-name lex-def) nil))))
     (setf (lexical-item-source-file lex-def) *currently-used-file*)

     ;; 4.0 if no gloss is specified, use the name...
     ;;
     (if (and (stringp (lexical-item-gloss lex-def))
	      (string= (lexical-item-gloss lex-def) ""))
	 (setf (lexical-item-gloss lex-def) 
	       (mapcar #'(lambda (sym) (if (keywordp sym) sym
					 (string sym)))
		       (lexical-item-name lex-def))))

     (setf (lexical-item-source-file lex-def) *currently-used-file*)
     (setf NameLst (get-atom-ls (lexical-item-name lex-def)))
     (loop for Lex-id in NameLst do
	   (setf (gethash (car Lex-id) lexicon) 
		 (merge-new-and-old-lexical-definition
		  (car lex-id) lex-def (cdr lex-id)))
	   (setf (lexical-item-LS-set lex-def) 
		 (union (cdr Lex-id) (lexical-item-LS-set lex-def)))
	   (pushnew (car NameLst) words)
     
	   (precompile-LexFtr LexFtr-lst Lex-id))
		 ; notice the trick of setf here. It creates two
                 ; hash index, but the actual storage of the lexical
                 ; item is only one, and shared by several indexes.
                 ; the LS-set field accumulates valid language specifiers
                 ; attached to each lexical name.
))

;;; ----------------------------------------------------------------------
;;; Removing...

(defun DELETE-LEXEME (lexeme)
;;; 0.7.8 was not severe enough (and moved from ml-newstyle-loading)
  (loop for feature in (lexical-item-features (gethash lexeme lexicon))
	do
	(replace-words-with-feature 
	 feature 
	 (remove lexeme
		 (fetch-lexemes-with-feature feature curlan))))
  (remhash lexeme lexicon)
  )

;;; ----------------------------------------------------------------------
;;; Existence...

;;; Following based on equivalent in ml-new-utilities.lisp
;;; 0.9 with speedup possibility considered...
;;; 2.0 redefined as method in order to allow cleaner integration
;;;     with external lexicons.

(defmethod LEXEME-DEFINED-FOR-LG-P (name lg)
  (let ((lexeme-instance (gethash name lexicon)))
    (and 
     lexeme-instance
     (member lg (lexical-item-ls-set lexeme-instance))
     (eq name (strip-lx (always-parse-clause 
			 (lexical-item-name lexeme-instance) lg))))))

(export 'LEXEME-DEFINED-FOR-LG-P "KPML")

;;; This method may be specialized for individual languages by 
;;; statements of the form:
;;;   (defmethod LEXEME-DEFINED-FOR-LG-P (name (lg (eql :english)))
;;;       form)
;;; etc.

;;; ----------------------------------------------------------------------
;;; Perusing...

(defun find-lexical-feature-like (substr)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (when (search (string-downcase substr)
			       (string-downcase (format nil "~a" key)))
		   (push key result-list)))
	     words-of-a-feature)
    result-list))

;;; Old Penman function: find-lexical-item-like 
;;; replaced by following...

;;; 0.9 following was not right for multilingual spellings which could
;;;     include numerous language conditionalizers...
(defun FIND-LEXICAL-ITEM-SPELLING-LIKE (substr)
  (let ((result-list nil))
    (maphash #'(lambda (key val)
		 val
		 (when 
		   (search 
		     (string-downcase substr)
		     (string-downcase 
		       (format nil "~a" 
			       (fetch-lexicon-info key 'spelling)
			       )))
		   (push (list key (lexical-item-spelling val)) result-list)))
	     lexicon)
    result-list))

(defun FIND-WORDS-SPELLED-LIKE (string)
  (maphash #'(lambda (key val)
	       (when (string-equal string 
				   (fetch-lexicon-info key 'spelling))
		     (print key))) lexicon))

;;; 2.0 missed the function following this one which does the work...
(defun LEXICAL-ITEMS-WITH-FEATURE (feature) 
  (print (fetch-lexemes-with-feature feature curlan)))

;-------------------------------------------------------------------------
;   "Retrieves the list of lexical items that have >>feature-name<< 
; as a grammatical feature.
;   The features are stored in the hash table words-of-a-feature."
;-------------------------------------------------------------------------

(defmethod FETCH-LEXEMES-WITH-FEATURE (feature-name curlan)
  (fetch-ftr-lex-assoc feature-name))

(export 'fetch-lexemes-with-feature "KPML")

;-------------------------------------------------------------------------
; "Replaces the list of lexical items that have >>feature-name<< as
; a grammatical feature."
;-------------------------------------------------------------------------

(defun replace-words-with-feature (feature-name new-value)
  (setf (fetch-ftr-lex-assoc feature-name) new-value))

(defsetf fetch-lexemes-with-feature replace-words-with-feature)

;;; ----------------------------------------------------------------------
;;; Old Penman function: add-proper-name-to-lexicon replaced by below...
;;; 
;;; ----------------------------------------------------------------------
;;; The following functions are now changed so that when the acquire lexical
;;; items flag is set, undefined lexical items mentioned in lex or name
;;; slots in the SPL are acquired under the names given by their spellings.
;;; These new lexical items are also maintained on a list so that they
;;; can be collectively output in new lexicon files. The spelling differs
;;; when the acquire mode is set, in that it tries to be appropriate rather
;;; than drawing attention to the lack of lexical definition (by being
;;; in upper case).
;;;
;;; March 2012: added a further flag which maintains the original style
;;;             viz capitalisation, etc. of the provided lexical item.

(defun ADD-STRING-TO-LEXICON (string features)
  "Creates a lexical item with FEATURES and STRING as its spelling;
   returns either a gensym or the spelling to serve as its key."
    (let ((sym (if *acquire-lexical-items-mode*
		   (intern string "KPML")
		 (gentemp "LEX")))
	  (spelling (substitute #\  #\. string)))
      (add-to-lexicon sym 
		      (if *acquire-lexical-items-mode*
			  (if *acquire-lexical-items-preserving-style-mode*
			      spelling
			    (string-downcase spelling))
			spelling)
		      features curlan)
      sym))

(defun ADD-STRING-TO-LEXICON-AS-PROPER-NAME (string)
  "Creates a lexical item with proper-name features and STRING as its spelling;
   returns a gensym which is its key."
  (let ((sym (if *acquire-lexical-items-mode*
		   (intern string :penman)
		 (gentemp "NAME")))
	(spelling (substitute #\  #\. string)))
    (add-to-lexicon sym 
		    (if *acquire-lexical-items-mode*
			(if *acquire-lexical-items-preserving-style-mode*
			      spelling
			  (string-capitalize spelling))
		      spelling)
		    '(not-provenance not-determinerrequired not-period
		      countable propernoun noinflections noun)
		    curlan)
    sym))

(defmethod ADD-TO-LEXICON (sym spelling features lg)
  (when (gethash sym lexicon)
    (warning "Lexical item: " sym " being automatically updated!"))
  (load-ml-lexicon
   `(:name ,(cons lg (list sym))
	   :spelling ,spelling
	   :features ,features))
  (when *acquire-lexical-items-mode* (pushnew sym *new-lexical-items*))
  (values))

(export 'add-to-lexicon "KPML")

;;; 3.2.58
;;; Following adds an example of a more useful default guess for
;;; lexical features for English. Individual languages can provide
;;; similar or more complex defaults. 

(defmethod ADD-TO-LEXICON (sym spelling features (lg (eql :english)))
  (let* ((ends-in-s-flag
	  ;; since this is an easy thing to check and makes a big
	  ;; difference to many ending in English, check it first...
	  ;;
	  (char= (char spelling (1- (length spelling))) #\s))
	 
	 (new-features
	  ;; here are the additions depending of word-class. This could
	  ;; become as complicated as you require...
	  ;;
	 (cond ((member 'noun features)
		(cons (if ends-in-s-flag 'es 's) features))
	       ((intersection 
		 '(do-verb symbolic-verb experience-verb relational-verb) 
		 features)
		(cons (if ends-in-s-flag 'es-ed 's-d) features))
	       ((member 'adjective features)
		(cons 'er-est features))
	       (t
		features))))

    ;; pass on the new feature list to be added to the lexicon in the
    ;; normal way... 
    ;;
    (if (next-method-p) 
	(call-next-method sym spelling new-features lg)
      (warning "Odd lexical item acquisition error with:" sym))
  ))


;;; ----------------------------------------------------------------------
;;; Functions taken over from object-management.lisp and multilingualized...

(defun LIST-LEXICAL-FEATURES (&optional (ls curlan))
  (declare (ignore ls))
  (hashtable-to-list words-of-a-feature))

;;; ----------------------------------------------------------------------
;;; Merging...

;;; 0.7.24:
;;; Following function was referring to the language of the old
;;; instance by removing the name from the ml-name spec: but this is
;;; silly, since the old languages are fully known and properly
;;; maintained in the -ls slot. This code was taken from the general
;;; merging code and so the correction should probably be made in the
;;; other merging functions to.  It only occured as a problem with the
;;; lexical definitions because the non-automatically generated
;;; lexicon files were missing the necessary in-language
;;; declaration. But this mistake should not cause the thing to
;;; bomb...

(defun MERGE-NEW-AND-OLD-LEXICAL-DEFINITION 
  (name new-instance lg-of-new-instance)
  (setf (lexical-item-ls-set new-instance) lg-of-new-instance)
  (when *show-loading-actions*
	(format *trace-output* "~%Loading lexical definition:  ~A" name))
  (cond ((and *merging-active*
	      (gethash name lexicon))
	 (let* ((old-instance (gethash name lexicon))
		(new-languages lg-of-new-instance)
		(old-languages (lexical-item-ls-set old-instance))
		(merged-instance nil)
		(old-lg-instance-pairs 
		 (create-set-of-mono-lingual-instances name :lexeme))
		(new-lg-instance-pairs
		 (create-set-of-mono-lingual-instances new-instance 
						       :lexeme)))

	   (when *show-loading-actions*
		 (format *trace-output* "~%...merging; old languages: ~A; new languages: ~A" 
		   old-languages new-languages))

	   (cond ((equal new-languages old-languages)
		  (when (member :lexemes *show-merging-actions*)
			(format *trace-output* "~%Lexeme ~A multiply defined, new definition wins."
				name))
		  new-instance)
		 ((intersection new-languages old-languages)
		  (when (member :lexemes *show-merging-actions*)
			(format *trace-output* "~%Merging for lexeme ~A; shared languages" name))
		  (merge-overlapping-lexical-item-instances
		   name old-lg-instance-pairs new-lg-instance-pairs))

		 (t
		  (when (member :lexemes *show-merging-actions*)
			(format *trace-output* 
                                "~%Merging for lexeme ~A; disjunctive languages" name))
		  (delete-lexeme name)
		  (setf merged-instance 
			(apply #'merge-lexeme-instances 
			       (list
				(append old-lg-instance-pairs 
				        new-lg-instance-pairs))))

		  (when (member :lexemes *show-merging-actions*)
			(format *trace-output* 
				"~%***Merged: old instance: ~%     ~A~%~
  ***new instance: ~A~%  ***and merged:~A~%" old-instance new-instance merged-instance))
		  merged-instance))))
	(t
	 (let* ((old-instance (gethash name lexicon)))
	   (when old-instance
		 (unless (subsetp (lexical-item-ls-set old-instance) 
				  lg-of-new-instance)
			 (warning "Previously existing lexeme: " name
				  " is being overwritten by a definition with narrower language coverage: " lg-of-new-instance " instead of " 
				  (lexical-item-ls-set old-instance)
				  "."))
		 (delete-lexeme name)))
	 (return-from merge-new-and-old-lexical-definition 
		      new-instance))))



(defun MERGE-OVERLAPPING-LEXICAL-ITEM-INSTANCES
  (name old-lg-instance-pairs new-lg-instance-pairs)
  
  (let ((merged-instance nil))
    (delete-lexeme name)
    (setf merged-instance 
	  (apply #'merge-lexeme-instances 
		 (list (replace-keyed-elements
			old-lg-instance-pairs 
			new-lg-instance-pairs))))
    
    (when (and *step-by-step-merging-behavior*
	       (member :lexemes *show-merging-actions*))
	  (format t 
		  "~%***Merged: old language instance pairs: ~%     ~S~%~
  ***new language instance pairs: ~S~%  ***and merged instance:~A~%" old-lg-instance-pairs new-lg-instance-pairs merged-instance))
    merged-instance))




(defun MERGE-LEXEME-INSTANCES (list-of-lg-instance-pairs)
  (let ((instance   (generalized-merge-instance
		     list-of-lg-instance-pairs
		     '(lexical-item-name
		       lexical-item-spelling
		       lexical-item-sample-sentence
		       lexical-item-features
		       lexical-item-properties
		       lexical-item-stem
		       lexical-item-gloss
		       lexical-item-translit
		       lexical-item-comments
		       lexical-item-editor
		       lexical-item-date
		       lexical-item-semantics
		       lexical-item-source-file)
		     #'make-lexical-item)))
    (setf (lexical-item-ls-set instance)
	  (mapcar #'first list-of-lg-instance-pairs))
    instance))

  
;;; ----------------------------------------------------------------------
;;; List conversions...

(defun LEXEME-TO-LIST-MULTI-TO-MONO 
  (lexeme
   &optional (lg-var curlan))
  (cond ((lexeme-defined-for-lg-p lexeme lg-var)
	 `(lexical-item
	  :name ,lexeme
	  :spelling ,(fetch-lexicon-info lexeme 'spelling lg-var)
	  :sample-sentence 
	    ,(fetch-lexicon-info lexeme 'sample-sentence lg-var)
	  :features ,(fetch-lexicon-info lexeme 'features lg-var)
	  :properties ,(fetch-lexicon-info lexeme 'properties lg-var)
	  :stem ,(fetch-lexicon-info lexeme 'stem lg-var)
	  :gloss ,(fetch-lexicon-info lexeme 'gloss lg-var)
	  :translit ,(fetch-lexicon-info lexeme 'translit lg-var)
	  :comments ,(fetch-lexicon-info lexeme 'comments lg-var)
	  :editor ,(fetch-lexicon-info lexeme 'editor lg-var)
	  :date ,(fetch-lexicon-info lexeme 'date lg-var)
	  :semantics ,(fetch-lexicon-info lexeme 'semantics lg-var)
	  :source-file ,(fetch-lexicon-info lexeme 'source-file lg-var)))
	(t nil)))

(defun LEXEME-TO-LIST-MULTI-TO-MULTI (lexeme-name)
  (lexeme-instance-to-list-multi-to-multi (gethash lexeme-name lexicon)))

(defun LEXEME-INSTANCE-TO-LIST-MULTI-TO-MULTI (lexeme)
    `(lexical-item
     :name ,(lexical-item-name lexeme)
     :spelling ,(lexical-item-spelling lexeme)
     :sample-sentence ,(lexical-item-sample-sentence lexeme)
     :features ,(lexical-item-features lexeme)
     :properties ,(lexical-item-properties lexeme)
     :stem ,(lexical-item-stem lexeme)
     :gloss ,(lexical-item-gloss lexeme)
     :translit ,(lexical-item-tranlit lexeme)
     :comments ,(lexical-item-comments lexeme)
     :editor ,(lexical-item-editor lexeme)
     :date ,(lexical-item-date lexeme)
     :semantics ,(lexical-item-semantics lexeme)
     :source-file ,(lexical-item-source-file lexeme)
     ))

(defun LEXEME-INSTANCE-TO-LIST-MULTI-TO-MONO 
  (instance &optional (lg-var curlan))
  `(lexical-item
    :name ,(strip-lx (parse-clause (lexical-item-name instance) lg-var))
    :spelling ,(strip-lx 
		(parse-clause (lexical-item-spelling instance) lg-var))
    :sample-sentence ,(strip-lx 
			(parse-clause 
			 (lexical-item-sample-sentence instance) lg-var))
    :features ,(strip-lx 
		(parse-clause (lexical-item-features instance) lg-var))
;;; 0.8.32 should not strip lexical properties
    :properties ,(parse-clause 
		   (lexical-item-properties instance) lg-var)
    :stem ,(strip-lx (parse-clause (lexical-item-stem instance) lg-var))
    :gloss ,(strip-lx (parse-clause (lexical-item-gloss instance) lg-var))
    :translit ,(strip-lx 
		(parse-clause (lexical-item-translit instance) lg-var))
    :semantics ,(strip-lx (parse-clause 
			   (lexical-item-semantics instance) lg-var))
    :source-file  ,(strip-lx (parse-clause 
			   (lexical-item-source-file instance) lg-var))
    :editor ,(strip-lx (parse-clause 
			(lexical-item-editor instance) lg-var))
    :comments ,(strip-lx (parse-clause 
			  (lexical-item-comments instance) lg-var))
    :date ,(strip-lx (parse-clause (lexical-item-date instance) lg-var))
    ))


;;; ----------------------------------------------------------------------
;;; Some basic utility functions (inherited from Penman) which may
;;; not be used anymore... defined the old word class hierarchy
;;; which appeared to disappear at some stage...

(defun fetch-lex-class-field (field class-name)
  "finds a particular word class, class-name, in the hash table 
   lexical-class-defs and returns the requested field."
  (let ((lex-class-item (gethash class-name lexical-class-defs)))
    (if lex-class-item 
	(case field
	      (class-id (inner-lex-class-class-id lex-class-item))
	      (super-class (inner-lex-class-super-class lex-class-item))
	      (added-features (inner-lex-class-added-features lex-class-item))
	      (sub-classes (inner-lex-class-sub-classes lex-class-item))
	      (lexical-items (inner-lex-class-lexical-items lex-class-item))
	      (group0 (inner-lex-class-group0 lex-class-item))
	      (group1 (inner-lex-class-group1 lex-class-item))
	      (comments (inner-lex-class-comments lex-class-item))
	      (edit (inner-lex-class-edit lex-class-item))
	      (t nil))
	nil)))

(defun replace-lex-class-field (field class-name new-value)
  "Finds a particular word class, class-name, and replaces its slot, 
  field, with new-value. The only field that should need to be replaced
  is lexical-items.  This is because the wordclasss herirarchy is not
  modified by nigel."
  (let ((lex-class-item (gethash class-name lexical-class-defs)))
    (unless lex-class-item (setq lex-class-item (make-inner-lex-class)))
    (case field
	  (class-id (setf (inner-lex-class-class-id lex-class-item)
			  new-value))
	  (super-class (setf (inner-lex-class-super-class lex-class-item)
			     new-value))
	  (added-features (setf
			    (inner-lex-class-added-features lex-class-item)
			    new-value))
	  (sub-classes (setf (inner-lex-class-sub-classes lex-class-item)
			     new-value))
	  (lexical-items (setf
			   (inner-lex-class-lexical-items lex-class-item)
			   new-value))
	  (group0 (setf (inner-lex-class-group0 lex-class-item)
			new-value))
	  (group1 (setf (inner-lex-class-group1 lex-class-item)
			new-value))
	  (comments (setf (inner-lex-class-comments lex-class-item)
			  new-value))
	  (edit (setf (inner-lex-class-edit lex-class-item)
		      new-value))
	  (t nil))
    (setf (gethash class-name lexical-class-defs) lex-class-item))
  new-value)

(defsetf fetch-lex-class-field replace-lex-class-field)

;;;

(defun GET-LEXICAL-PROPERTY-VALUE (prop proplist)
  (let ((inflected-form (find prop proplist :key #'car)))
    (cond (inflected-form
	   (cadr inflected-form))
	  (t
	   (warning "The grammatical feature " prop " was not found in the property list " proplist " of the lexical item.")
	   nil))))
	   

;;; 4.0 in case we ever remove the unused lexical item features...
;;;     and some miscellaneous tools for interrogating the grammar...

(defun PRUNE-LEXEME-FEATURES (lex)
            (let ((features (fetch-lexicon-info lex 'features)))
              (intersection features (get-classify-inflectify-features))))

(defun GET-ASSOCIATED-FEATURES-AND-FUNCTIONS-FOR-LEXEME (lex)
            (let* ((features (prune-lexeme-features lex))
                   (results
                    (loop for (s (f . realizations))
                          in (loop for l1 in features append (kpml-who-can-classify l1))
                          collect f into features-using
                          append (loop for r in realizations collect (second r)) into functions-using
                          finally (return (cons features-using functions-using))))
                   (features-using (sort (remove-duplicates (first results)) #'string<))
                   (functions-using (sort (remove-duplicates (cdr results)) #'string<)))

              (format t "~%Features (~S): ~{~%~10T~S~}" (length features-using) features-using)
              (format t "~%Functions (~S): ~S" (length functions-using) functions-using)))
