(in-package "KPML-I")

;;; File: lexeme-editor.lisp
;;; John:Bremen:Nov-Dec 2000
;;; Version 1.

;;; Since all the work is more or less already done (or so the comment
;;; from  the  inquiry  editor  on  which  this  file  is  based  from
;;; Edinburgh,  Nov 97  says...)  add  a KPML-only  editing  frame for
;;; lexeme definitions.  This avoids having  to edit these  outside in
;;; Emacs which is good for the standalone particularly.

;;; Should be much simpler than the inquiries though... 
;;;  ... don't try to do anything fancy yet.

;;; ----------------------------------------------------------------------
;;; Basics...
;;; ----------------------------------------------------------------------

(defvar *used-lexical-features* nil)
(defvar *who-is-editing?* nil)
(defvar *edited-lexemes* nil)

;;; ----------------------------------------------------------------------
;;; Misc... Many of the next globals should in fact be turned into
;;;         open lists that are partially user definable and then
;;;         also multilingual!!
;;; ----------------------------------------------------------------------

(defvar *kpml-word-classes* 
  '(kpml::noun kpml::adjective kpml::adverb kpml::verb kpml::conjunction kpml::linker))

(defvar *kpml-irregular-ending-types* 
  '(kpml::Irr KPML::*-IRR KPML::S-IRR KPML::ES-IRR))

(defvar *verb-paradigm-props*
  '((1s . firstsingularform)
    (3s . thirdsingularform)
    (pl . pluralform)
    (1s-past . firstsingularpastform)
    (pl-past . pluralpastform)
    (ing . ingparticipleform)
    (ed . edparticipleform)))

(defvar *noun-paradigm-props*
  '((sg . singularform)
    (pl . pluralform)))

(defvar *adj-paradigm-props*
  '((base . nil)
    (comp . comparativeform)
    (sup . superlativeform)))

(defun SELECT-ENDING-TYPES (class-type)
  (case class-type
	(kpml::verb
	 '(KPML::STRONG KPML::ES-ED KPML::S-*ED KPML::S-ED KPML::S-D KPML::*-IRR KPML::S-IRR KPML::ES-IRR KPML::IRR))
	(kpml::noun
	 '(KPML::ES KPML::S KPML::IRR))
	(kpml::adverb 
	 nil)
	(kpml::adjective
	 '(KPML::ER-EST KPML::R-ST KPML::*ER-*EST KPML::IRR))
	(t
	 nil)))

(defun INIT-USED-LEXICAL-FEATURES ()
  (let* ((l1 (copy-list (kpml::who-can-classify)))
	 (l2 (copy-list (kpml::who-can-out-classify)))
	 (l3 (append l1 l2)))
    (declare (special *used-lexical-features*))
    (setf *used-lexical-features*
	  (remove-duplicates
	   (kpml::flatten
	    (mapcar #'(lambda (x) (mapcar #'cddr (second x))) l3))))))


(defun INIT-USED-LEXICAL-PROPERTIES ()
  (let ((props-list nil))
    (maphash #'(lambda (key value) 
		 (let ((props 
			(kpml::fetch-lexicon-info key 'kpml::properties)))
		   (loop for (p v) in props do (pushnew p props-list))))
	     kpml::lexicon)
    (sort props-list #'string< )))

;;; ----------------------------------------------------------------------
;;; For display...
;;; ----------------------------------------------------------------------

(defun MAKE-LEXICAL-PARADIGM (spelling class-type ending-type properties)
  (unless (or (string= spelling "")
	      (null spelling))
    (loop for (l . p) 
	  in (case class-type
		   (kpml::verb *verb-paradigm-props*)
		   (kpml::noun *noun-paradigm-props*)
		   (kpml::adjective *adj-paradigm-props*))
	  collect 
	  (cons l (kpml::generate-inflected-word 
		   spelling
		   ending-type 
		   properties
		   (find-symbol (symbol-name p) "KPML"))))))

;;; ----------------------------------------------------------------------
;;; Some presentation types for the editing and display actions below...
;;; ----------------------------------------------------------------------

(clim:define-presentation-type feature-display-mode ())
(clim:define-presentation-type lexical-feature ())
(clim:define-presentation-type properties-list ())
(clim:define-presentation-type clear-properties-list ())
(clim:define-presentation-type add-property ())
(clim:define-presentation-type add-class-type ())

;;; ----------------------------------------------------------------------
;;; Some Markus magic...
;;; ----------------------------------------------------------------------

(defconstant +pp-option-pane-view+
    '(clim:option-pane-view :name-key print-pretty)
  "An option-pane-view which displays its values slightly different than
normal.")

(defun print-pretty (symbol)
  (format nil "~(~A~)" (if symbol symbol 'none)))

;;; ----------------------------------------------------------------------
;;; Regular frame definitions...
;;; ----------------------------------------------------------------------

(clim:define-application-frame 
 LEXEME-EDITING-FRAME ()
 ((name :initform nil)
  (feature-display-mode :initform :grammar)
  (class-type :initform nil)
  (ending-type :initform nil)
  (modified :initform nil)
  (edited-lexeme :initform (kpml::make-lexical-item)))
 (:menu-bar T)
 (:command-table 
  (lexeme-editing-frame
   :inherit-from (clim:user-command-table clim:accept-values-pane)))
 (:top-level (clim:default-frame-top-level))
 (:panes 
  #+ignore(menu :command-menu
		:foreground menu-fg
		:background menu-bg
		:text-style *menu-font*)
  (def-pane
   :accept-values :scroll-bars nil
   :display-function
   '(clim:accept-values-pane-displayer :displayer edited-lexeme-displayer
;;     :resynchronize-every-pass T
     )
   :foreground inspector-fg :background inspector-bg 
   :text-style *sans-serif--bold--10*)
  (paradigm-pane
   :application  :scroll-bars :vertical
   :incremental-redisplay T
   :initial-cursor-visibility :inactive
   :display-function 'paradigm-displayer
   :foreground inspector-fg :background inspector-bg 
   :text-style *fix--bold--10*)
  (features-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :initial-cursor-visibility :inactive
   :display-function 'features-displayer
   :foreground inspector-fg :background inspector-bg 
   :text-style *sans-serif--roman--10*)
  (properties-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :initial-cursor-visibility :inactive
   :display-function 'properties-displayer
   :foreground inspector-fg :background inspector-bg 
   :text-style *sans-serif--roman--10*)
  (comments-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :end-of-line-action :wrap
   :end-of-page-action :allow
   :initial-cursor-visibility :inactive
   :display-function 'comments-displayer
   :foreground inspector-fg :background inspector-bg 
   :text-style *sans-serif--bold--8*)
  (sample-sentence-pane
   :application :incremental-redisplay T :scroll-bars :vertical
   :initial-cursor-visibility :inactive
   :display-function 'sample-sentence-displayer
   :foreground inspector-fg :background inspector-bg 
   :text-style *sans-serif--roman--10*)
  (leet-pane
   :accept-values :scroll-bars nil
   :display-function
   '(clim:accept-values-pane-displayer :displayer leet-lexeme-displayer
     :resynchronize-every-pass T)
   :foreground inspector-fg :background inspector-bg 
   :text-style *fix--bold--10*)
  (mouse-doc   :pointer-documentation
	       :foreground  mouse-doc-fg
	       :background  mouse-doc-bg))
 (:layouts
  (one-and-only
   (clim:vertically 
    ()
;;    #-lispworks (25 menu) #+lispworks menu
    (1/7 def-pane)
    (1/8 sample-sentence-pane)
    (:fill
     (clim:horizontally ()
			(1/4
			 (clim:vertically ()
					  (1/5 leet-pane)
					  (:fill paradigm-pane)
					  ))
			(1/3 features-pane)
			(:fill 
			 (clim:vertically ()
					  (:fill properties-pane)
					  (1/5 comments-pane)))))
    #-lispworks (20 mouse-doc)
    ))))


  ;; ----------------------------------------------------------------------
  ;; Display methods...
  ;; ----------------------------------------------------------------------

(defmethod SAMPLE-SENTENCE-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots (edited-lexeme) frame
    (print (kpml::lexical-item-sample-sentence edited-lexeme) stream)))

(defmethod COMMENTS-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots (edited-lexeme) frame
    (print (kpml::lexical-item-comments edited-lexeme) stream)))

(defmethod PARADIGM-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots (ending-type class-type name edited-lexeme) 
	      clim:*application-frame*
     (let ((properties (kpml::lexical-item-properties edited-lexeme))
	   (spelling (kpml::lexical-item-spelling edited-lexeme)))
       (if ending-type
	   (progn
	     (clim:with-text-face 
	      (stream :bold)
	      (format stream "Paradigm (~A): " ending-type))
	     (if (string= spelling "")
		 (clim:with-text-size
		  (stream :larger)
		  (format stream "~%No spelling."))
	       (loop for (l . f) 
		     in (make-lexical-paradigm 
			 spelling class-type ending-type properties)
		     do (format stream "~%~A: ~A" l f ))))
	  (clim:with-text-size
		  (stream :larger)
		  (format stream "~%No ending type."))
	  ))))

(defmethod PROPERTIES-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots 
   (modified name edited-lexeme) frame
   (clim:with-output-as-presentation 
    (stream T 'properties-list)
    (clim:with-text-face 
     (stream :bold)
     (format stream "Properties:")))
   (clim:with-text-size
    (stream :smaller)
    (clim:with-text-face 
     (stream :italic)
     (clim:with-output-as-presentation 
      (stream T 'clear-properties-list)
      (format stream "~10T(Clear)"))
     (format stream "                     ")      
     (clim:with-output-as-presentation 
      (stream T 'add-property)
      (clim:with-drawing-options
       (stream :ink clim:+red+)
       (clim:surrounding-output-with-border
	(stream :shape :rectangle)
	(format stream "Add"))))))

   (loop for (prop value) in (kpml::lexical-item-properties edited-lexeme)
	 do 
	 (clim:with-text-size
	  (stream :smaller)
	  (format stream "~%~A" prop))
	 (format stream "~3T~S" value)
	 )))

(defmethod LEET-LEXEME-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots 
     (modified class-type ending-type) frame
     (let ((old-ending-type ending-type)
	   (endings (select-ending-types class-type)))
       (clim:with-text-face 
	(stream :italic)
	(format stream "Class type: ~A~%Ending type..." class-type))
       (cond (endings
	      (kpml-i-terpri stream)
	      (setf ending-type
		    (clim:accept `(member ,@endings)
				 :view +pp-option-pane-view+
				 :stream stream
				 :prompt "Ending type:"
				 :default ending-type))
	      (unless (equal old-ending-type ending-type) (setf modified T)))
	     (t
	      (format stream "~% Uninflectable."))))))

(defmethod FEATURES-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots 
   (modified name edited-lexeme feature-display-mode ending-type) frame
   (let ((features
	  (case feature-display-mode
		(:grammar 
		 (loop for f in (kpml::lexical-item-features edited-lexeme)
		       when (member f *used-lexical-features*)
		       collect f))
		(:used (kpml::lexical-item-features edited-lexeme))
		(:all (cons ending-type
			    (kpml::lexical-item-features edited-lexeme))))))
     (clim:with-output-as-presentation 
      (stream feature-display-mode 'feature-display-mode)
      (clim:with-text-face 
       (stream :bold)
       (format stream "Features (~A:~A):" 
	       feature-display-mode (length features))))
     (clim:with-output-as-presentation 
      (stream T 'add-class-type)
      (clim:with-drawing-options
       (stream :ink clim:+red+)
       (clim:surrounding-output-with-border
	(stream :shape :rectangle)
	(format stream "Class"))))
     (loop for f in (sort (copy-list features) #'string<)
	    do (format stream "~%~(~A~)" f)))))

(defmethod EDITED-LEXEME-DISPLAYER  ((frame lexeme-editing-frame) stream)
  (with-slots 
   (modified name edited-lexeme) frame
   (macrolet 
    ((spelling () '(kpml::lexical-item-spelling edited-lexeme))
     (stem  () '(kpml::lexical-item-stem edited-lexeme)))
    (let ((old-stem (stem))
	  (old-spelling (spelling)))
      (clim:with-text-face 
       (stream :italic)
       (clim:with-text-size
	(stream :larger)
	(setf name (clim:accept 'clim:symbol :stream stream
				#+lispworks :view
				#+lispworks clim:+textual-dialog-view+
				:default name :prompt "Lexical item name"))
       
	(kpml-i-terpri stream)
	(setf (spelling) 
	      (clim:accept 'clim:string :stream stream
			   #+lispworks :view
			   #+lispworks clim:+textual-dialog-view+
			   :default (spelling) :prompt "Lexical spelling"))
	(kpml-i-terpri stream)
	(setf (stem) (clim:accept 'clim:string :stream stream
				  #+lispworks :view
				  #+lispworks clim:+textual-dialog-view+
				  :default (stem) :prompt "Lexical stem"))

	(unless (and 
		 (equal (spelling) old-spelling)
		 (equal (stem) old-stem)
		 )
	  (setf modified T))
	(setf (kpml::lexical-item-name edited-lexeme) 
	      (list kpml::curlan name))
	nil))))))

;;; ----------------------------------------------------------------------
;;; Menu...

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FRAME-QUIT :name "Quit" :menu t)
    ()
  (with-slots (modified edited-lexeme name ending-type)
     clim:*application-frame*
     (when (and modified
	       (eq (startup-user-response-frame
		    '("Modified lexeme has not been saved. Save it first?"))
		   :yes))
      (export-edited-lexeme name edited-lexeme ending-type)
      (setf modified nil))
    (close-a-window clim:*application-frame*)))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FRAME-EXPORT :name "Export" :menu t)
    ()
  (with-slots (modified edited-lexeme ending-type name) 
    clim:*application-frame*
    (when modified
      (export-edited-lexeme name edited-lexeme ending-type)
      (pushnew name *edited-lexemes*)
      (setf modified nil))))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FRAME-CLEAR :name "Clear" :menu t)
    ()
  (with-slots (modified name edited-lexeme) clim:*application-frame*
    (setf name nil)
    (setf modified T)
    (setf edited-lexeme (kpml::make-lexical-item))))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-REVERT :name "Revert" :menu t)
    ()
  (with-slots (name) clim:*application-frame*
    (if (kpml::lexeme-defined-for-lg-p name kpml::curlan)
	(initialize-edited-lexeme name clim:*application-frame*)
      (clim:notify-user 
       clim:*application-frame*
       (concatenate 'string
	 "No lexeme named " 
	 (string name)
	 " currently saved for language: "
	 (string kpml::curlan))))))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FRAME-COMMENTS :name "Comments" :menu t)
    ()
  (with-slots (modified name edited-lexeme) clim:*application-frame*
    (let ((edit (edit-string-block 
		 (let ((c (kpml::lexical-item-comments edited-lexeme)))
		   (if (and c (or (and (stringp c)
				       (not (string= c "")))
				  (and (consp c)
				       (not (equal c '(""))))))
		       (kpml::lexical-item-comments edited-lexeme)
		     "no comments"))
		 :label "Edit lexeme comment (click middle to modify)"
		 :height 100 :width 200)))
      (when edit
	(setf (kpml::lexical-item-comments edited-lexeme) edit)
	(setf modified T)))))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FRAME-SAMPLE :name "Sample sentence" :menu t)
    ()
  (with-slots (modified name edited-lexeme) clim:*application-frame*
    (let ((edit (edit-string-block 
		 (let ((c (kpml::lexical-item-sample-sentence edited-lexeme)))
		   (if (and c (or (and (stringp c)
				       (not (string= c "")))
				  (and (consp c)
				       (not (equal c '(""))))))
		       (kpml::lexical-item-sample-sentence edited-lexeme)
		     "no sample sentence"))
		 :label "Edit lexeme sample sentence (click middle to modify)"
		 :height 100 :width 200)))
      (when edit
	(setf (kpml::lexical-item-sample-sentence edited-lexeme) edit)
	(setf modified T)))))

(define-lexeme-editing-frame-command 
    (com-LEXEME-EDITING-FINDER :name "Find" :menu t)
    ()
    (with-slots (name) clim:*application-frame*
      (let ((candidates 
	     (mapcar #'car (kpml::find-lexical-item-spelling-like name))))
	(if candidates
	    (let ((new-name 
		   (choose-from-list 
		    (sort candidates #'string<)
		    :name "Choose lexeme")))
	      (initialize-edited-lexeme new-name clim:*application-frame*))
	  (clim:notify-user 
	   clim:*application-frame*
	   (concatenate 'string
			"No lexemes with spelling like " 
			(string name)
			" currently defined for language: "
			(string kpml::curlan)))))))

;;; ----------------------------------------------------------------------
;;; Action definitions...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action 
 SET-FEATURE-DISPLAY-MODE
 (feature-display-mode nil lexeme-editing-frame
    :documentation "Toggle features used in grammar, used anywhere, and all")
 (object)
 (with-slots (feature-display-mode) clim:*application-frame*
	     (setf feature-display-mode
		   (case feature-display-mode
			 (:grammar :used)
			 (:used :all)
			 (:all :grammar)))
	     (clim:redisplay-frame-pane 
	      clim:*application-frame* 'features-pane :force-p T)))


(clim:define-presentation-action 
 SET-PROPERTIES
 (properties-list nil lexeme-editing-frame
		  :documentation "Edit the existing properties")
 (object)
 (with-slots (edited-lexeme) clim:*application-frame*
	     (edit-lexeme-properties edited-lexeme)
	     (clim:redisplay-frame-pane 
	      clim:*application-frame* 'properties-pane :force-p T)
	     (clim:redisplay-frame-pane 
	      clim:*application-frame* 'paradigm-pane :force-p T)))

(clim:define-presentation-action 
 CLEAR-PROPERTIES
 (clear-properties-list nil lexeme-editing-frame
			:documentation "Clear the property list")
 (object)
 (with-slots (edited-lexeme) clim:*application-frame*
	     (setf (kpml::lexical-item-properties edited-lexeme) nil)
	     (clim:redisplay-frame-pane 
	      clim:*application-frame* 'properties-pane :force-p T)
	     (clim:redisplay-frame-pane 
	      clim:*application-frame* 'paradigm-pane :force-p T)))

(clim:define-presentation-action 
 ADD-PROPERTY
 (add-property nil lexeme-editing-frame
	       :documentation "Add a further property")
 (object)
 (block  add-property-block
  (with-slots (edited-lexeme modified ending-type) 
   clim:*application-frame*
   (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	  (possible-props 
	   (sort
	    (set-difference
	     (init-used-lexical-properties)
	     (mapcar #'car (kpml::lexical-item-properties edited-lexeme)))
	    #'string<))
	  (selected-prop (car possible-props))
	  (selected-value ""))
     (restart-case
      (positioned-accepting-values
       (stream :own-window kpml-i::*own-window*
	       :x-position (first kpml-i::*confirmation-popups-xy*)
	       :y-position (second kpml-i::*confirmation-popups-xy*)
	       :width 500
	       :resynchronize-every-pass t
	       :label "Add lexeme properties" :exit-boxes 
	       '((:exit "Click here to accept")
		 (:abort "Click here to cancel"))) 
       (setf selected-prop (clim:accept `(member ,@possible-props)
                                        :view +pp-option-pane-view+
			    :stream stream
			    :prompt "Select property"
			    :default selected-prop))
       (kpml-i-terpri stream)
       (format stream "~2%Property ~A has value: " selected-prop)
       (setf selected-value
	     (clim:accept 'clim:string :stream stream
			  #+lispworks :view 
			  #+lispworks clim:+textual-dialog-view+
			  :prompt ""
			  :default selected-value))
       (kpml-i-terpri stream)
       (setf ending-type
	     (clim:accept 
	      `(clim:member-sequence ,*kpml-irregular-ending-types*)
	      :stream stream
	      :view 
	      #-lispworks 'clim:list-pane-view
	      #+lispworks clim:+textual-dialog-view+
	      :prompt "Select ending type"
	      :default ending-type))
       (kpml-i-terpri stream))
      (abort () (return-from ADD-PROPERTY-BLOCK nil)))
     (setf (kpml::lexical-item-properties edited-lexeme) 
	   (cons 
	    (list selected-prop selected-value)
	    (kpml::lexical-item-properties edited-lexeme)))
     (pushnew selected-prop 
	      (kpml::lexical-item-features edited-lexeme))
     (setf modified T)
     (loop for pane in '(properties-pane features-pane paradigm-pane)
	   do
	   (clim:redisplay-frame-pane 
	    clim:*application-frame* pane :force-p T))))))


;;; ----------------------------------------------------------------------
;;; Class type brute force...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action 
 ADD-CLASS-TYPE
 (add-class-type nil lexeme-editing-frame
		 :documentation "Set the lexical class of the entry")
 (object)
 (block 
  add-class-type-block
  (with-slots (edited-lexeme modified class-type) clim:*application-frame*
   (let ((new-class-type class-type)
	 (stream (clim::frame-top-level-sheet clim:*application-frame*)))
     (restart-case
      (positioned-accepting-values
       (stream :own-window kpml-i::*own-window*
	       :x-position  (first kpml-i::*confirmation-popups-xy*)
	       :y-position  (second kpml-i::*confirmation-popups-xy*)
	       :label "Class type" :exit-boxes 
	       '((:exit "Click here to accept")
		 (:abort "Click here to cancel")))
       (setf new-class-type (clim:accept `(member ,@*kpml-word-classes*)
					 :view +pp-option-pane-view+
					 :stream stream
					 :prompt "Class type:"
					 :default new-class-type))
       (kpml-i-terpri stream))
      (abort () (return-from ADD-CLASS-TYPE-BLOCK nil)))
     (setf modified T)
     (setf (kpml::lexical-item-features edited-lexeme)
	   (cons new-class-type
		 (remove class-type 
			 (kpml::lexical-item-features edited-lexeme))))
     (setf class-type new-class-type)
     (loop for pane in '(properties-pane features-pane paradigm-pane leet-pane)
	   do
	   (clim:redisplay-frame-pane 
	    clim:*application-frame* pane :force-p T))))))
 

;;; ----------------------------------------------------------------------
;;; Edit the properties list
;;; ----------------------------------------------------------------------

(defun EDIT-LEXEME-PROPERTIES (edited-lexeme)
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(properties (kpml::lexical-item-properties edited-lexeme)))
    (with-slots (modified) clim:*application-frame*
    (restart-case
     (positioned-accepting-values
      (stream :own-window kpml-i::*own-window*
	      :x-position (first kpml-i::*confirmation-popups-xy*)
	      :y-position (second kpml-i::*confirmation-popups-xy*)
	     :label "Lexeme properties editor" :exit-boxes 
	     '((:exit "Click here to accept")
	       (:abort "Click here to cancel")))
     (setf 
      properties
      (loop for (prop val) in properties
	    collect
	    (list prop
		  (clim:accept 'clim:string :stream stream
			       #+lispworks :view 
			       #+lispworks clim:+textual-dialog-view+
			       :prompt (string prop)
			       :default val))
	    do
	    (kpml-i-terpri stream))))
     (abort () (return-from EDIT-LEXEME-PROPERTIES nil)))
    (setf (kpml::lexical-item-properties edited-lexeme) 
	  (loop for (prop val) in properties
		unless (or (string= val "")(null val)) 
		collect (list prop val)))
    (setf modified T))))

;;; ----------------------------------------------------------------------
;;; Work for exporting, prechecks, saving, and protocolling...

(defun EXPORT-EDITED-LEXEME (name lexeme ending-type)
  (when (edited-lexeme-exportable-p lexeme)
    (clear-up-edited-properties lexeme)
    (kpml::load-ml-lexicon
     `(:name ,(list kpml::curlan name)
	     :features ,(cons ending-type (kpml::lexical-item-features lexeme))
	     :properties ,(kpml::lexical-item-properties lexeme)
	     :spelling ,(kpml::lexical-item-spelling lexeme)
	     :stem ,(kpml::lexical-item-stem lexeme)
	     :sample-sentence ,(kpml::lexical-item-sample-sentence lexeme)
	     :comments 
	     ,(kpml::lexical-item-comments lexeme)
	     :editor
	     ,*who-is-editing?*
	     :date ,(list (kpml::time-stamp))))
    ;; and protocol the edit....
    (kpml::protocol-edit
     (kpml::systemic-display 
      name
      :object-type :lexeme :stream nil)))
  )

(defun CLEAR-UP-EDITED-PROPERTIES (lexeme)
  (let* ((possible-properties (init-used-lexical-properties))
	 (new-properties 
	  (mapcar #'car (kpml::lexical-item-properties lexeme))))
    (setf (kpml::lexical-item-features lexeme)
	  (loop for f in (kpml::lexical-item-features lexeme)
		if (member f new-properties)
		collect f
		else
		when (not (member f possible-properties))
		collect f))))
		  
(defun EDITED-LEXEME-EXPORTABLE-P (lexeme)
  (cond ((null (kpml::lexical-item-name lexeme))
	 (clim:notify-user clim:*application-frame*
			   "No lexeme name defined.")
	 nil)
	((null (slot-value clim:*application-frame* 'ending-type))
	 (clim:notify-user clim:*application-frame*
			   "No ending type for lexeme defined.")
	 nil)
	(T
	 (or (member :resource-patches kpml::*loading-saving-profile*)
	     (eq (startup-user-response-frame
		  '("Patch versioning is not activated. Do you really want to change the loaded resources?"))
		 :yes)))))


;;; ----------------------------------------------------------------------
;;; Get the show on the road...

;;; Initialization...

;;; An example lexical item:
;(LEXICAL-ITEM NAME (:ENGLISH SAIL) SPELLING "sail" SAMPLE-SENTENCE "Knox sails tonight" FEATURES (NOT-THATCOMP OBJECTNOTPERMITTED NOT-BAREINFINITIVECOMP NOT-PARTICIPLECOMP NOT-SUBJECTCOMP NOT-ADJECTIVECOMP EVENT DO-VERB MIDDLE-VERB NOT-MAKECOMP NOT-QUESTIONCOMP NOT-TOCOMP NOT-CASEPREPOSITIONS LEXICAL S-ED UNITARYSPELLING INFLECTABLE VERB) PROPERTIES NIL STEM "" COMMENTS "process" EDITOR "whitney" DATE "01/24/90 14:21:28" SEMANTICS NIL LS-SET (:ENGLISH) SOURCE-FILE #P"d:/resources/ENGLISH/Lexicons/megalex.lexicon")


(defun COPY-ACROSS-INITIALLY-UNCHANGED-LEXEME-SLOTS (source lex-frame)
  (with-slots (edited-lexeme) lex-frame
    (setf (kpml::lexical-item-spelling edited-lexeme)
	  (kpml::fetch-lexicon-info source 'kpml::spelling))
    (setf (kpml::lexical-item-sample-sentence edited-lexeme)
	  (kpml::fetch-lexicon-info source 'kpml::sample-sentence))
    (setf (kpml::lexical-item-comments edited-lexeme)
	  (kpml::fetch-lexicon-info source 'kpml::comments))))

(defun INITIALIZE-EDITED-LEXEME (lexeme lex-frame)
  (with-slots (name edited-lexeme modified class-type ending-type) lex-frame
	      (setf name lexeme)
	      (setf edited-lexeme
		    (kpml::fetch-lexicon-info lexeme 'kpml::everything))
	      (setf (kpml::lexical-item-name edited-lexeme)
		    (kpml::strip-ml 
		     (kpml::lexical-item-name edited-lexeme)
		     kpml::curlan))
	      (setf ending-type
		    (first 
		     (intersection 
		      kpml::*lexical-entry-ending-types*
		      (kpml::lexical-item-features edited-lexeme))))
	      (setf (kpml::lexical-item-features edited-lexeme)
		    (remove ending-type 
			    (kpml::lexical-item-features edited-lexeme)))
	      (setf class-type
		    (first 
		     (intersection
		      *kpml-word-classes*
		      (kpml::lexical-item-features 
		       (slot-value lex-frame 'edited-lexeme)))))
	      (copy-across-initially-unchanged-lexeme-slots lexeme lex-frame)
	      (setf modified nil)))

;;; ----------------------------------------------------------------------
;;; Bring up the window...
;;; Extra options for when the lexeme is being built new. This is
;;; triggered by the lexeme given being NIL.
;;; Starting defaults can then include:
;;;   (a) the name it should have.
;;;   (b) the features that the grammar wants it to have
;;; Uses standard KPML 3 frame starting methods.
;;; ----------------------------------------------------------------------

(define-kpml-i-frame-starter 
  STARTUP-A-LEXEME-EDITOR-FRAME-INTERNAL
  lexeme-editing-frame
  "KPML LEXEME EDITOR"
  *frame*
  :args (lexeme features name)
  :layout 
  (:pretty-name (concatenate 
		 'string 
		 "Lexeme editing frame ("
		 (if lexeme (string lexeme) "new lexeme") ") [version 1]")
		:height 550
		:width 700)
  :body (
	 (init-used-lexical-features)
	 (cond (lexeme (initialize-edited-lexeme lexeme frame))
	       (t (setf (slot-value frame 'modified) nil)
		  (setf (slot-value frame 'name) name)
		  (when features
		    (setf (kpml::lexical-item-features
			   (slot-value frame 'edited-lexeme))
			  features))
		  (setf (slot-value frame 'ending-type)
			(first 
			 (intersection 
			  kpml::*lexical-entry-ending-types*
			  (kpml::lexical-item-features 
			   (slot-value frame 'edited-lexeme)))))
		  (setf (slot-value frame 'class-type)
			(first
			 (intersection
			  '(kpml::noun kpml::adjective kpml::adverb kpml::verb kpml::conjunction kpml::linker)
			  (kpml::lexical-item-features 
			   (slot-value frame 'edited-lexeme)))))
			))))

(defun STARTUP-A-LEXEME-EDITOR-FRAME 
    (lexeme &key 
	    (frame-tool-label nil)
	    (features nil)
	    (name nil))
    (startup-a-lexeme-editor-frame-internal 
     lexeme features name
     :frame-tool-label frame-tool-label))







