(in-package "KPML")

;;; File: cautious-rs-dialog-box.lisp
;;;
;;; 2.0.57
;;; ***  This entire file IS ONLY RELEVANT FOR LISPWORKS!!!        ***
;;; ***  but can also be loaded without problems in any other Lisp ***
;;;
;;; Under Lispworks 4.0 with localized Eastern European Windows98/etc.
;;; Harlequin CLIM 2.0/1 fails to bring up certain, as yet not well
;;; understood, windows. There is an unusable and unrestartable from
;;; Error Message: `assertion failing'. 
;;; 
;;; This has happened most consistently for the dialog box that allows
;;; editing and entering of realization statements from the KPML 
;;; system editor. 
;;; 
;;; First feedback of problem...
;;;   from Jiri: backtraces from failed assertion.
;;;   assertion fails within a clim recompute extent method inside the
;;;   incremental output updating method clim:tree-recompute-extent. This
;;;   is all within a formatting cell. kpml-edit-protocol shows the function
;;;   to have been entered, stream is a clim:top-level-sheet. Default
;;;   is set appropriately (of course! let's not forget that this 
;;;   is a Harlequin CLIM bug!). Control is within the accepting-values
;;;   body and within a formatting-item-list
;;;   and such stuff. This is used by the member-sequence presentation type.
;;;   Given that other Lispworks sequence presentation types are a bit
;;;   flakey, this could be the source of problems. 
;;; 
;;; Treatment:
;;;
;;;   This may be overkill, but here we just replace the entire dialog
;;;   box with a completely different application frame and be done with it...
;;;
;;;   We also add this behaviour as a `KPML option' settable from the
;;;   KPML options when under Lispworks.
;;; ----------------------------------------------------------------------

(defvar *RS-SELECTION-MADE* nil)
(defvar *CONSTRUCTED-RS* nil)
(defvar *RS-PROCESS* nil)

(clim:define-application-frame 
    RS-BUILDING-FRAME ()
  ((rs :initform nil)
   (selected-realop :initform nil)
   (feature :initform nil))
  (:menu-bar NIL)
   (:command-table 
    (rs-building-commands
     :inherit-from (clim:accept-values-pane clim:user-command-table)))
   (:top-level (clim:default-frame-top-level))
  (:panes 
   (rs-description :accept-values
	           :display-function '(clim:accept-values-pane-displayer
                                       :displayer rs-building-displayer
                                       :resynchronize-every-pass T))
   (rs-options :command-menu
               :height 80
               :max-height 80
               :display-function #'rs-menu-displayer
               :text-style kpml-i::*menu-font*))
  (:layouts
   (first (clim:vertically () 
	    (:fill rs-description) 
	    (#-lispworks 70 #+lispworks 1/4 rs-options)))))

(defun RS-MENU-DISPLAYER 
  (frame stream &key (max-height nil)(max-width nil))
  (declare (ignore frame max-width))
  (clim:display-command-table-menu 
   (clim:find-command-table 'rs-building-commands)
   stream
   :row-wise t
   :max-height max-height
   :n-columns 5))

(defmethod RS-BUILDING-DISPLAYER ((frame rs-building-frame) stream)
  (with-slots (rs selected-realop feature) frame
    (let* ((rs-op selected-realop)
           (default rs)
           (op1 (if default (second default) nil))
	   (op2 (if default (third default) nil)))
      (macrolet 
	  ((incomplete ()
	     '(clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
	       (clim:with-drawing-options 
		   (stream :ink clim:+red+)
		 (format stream "~%Realization statement INCOMPLETE.")
		 (format stream "~%   (Accepting will have no effect.)")))))
	
        (clim:with-text-style (stream kpml-i::*sans-serif--bold--8*)
	  (when feature
	    (clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
	      (format stream 
		      "~%You are creating/editing a realization statement")
	      (format stream 
		      "~%for the grammatical feature: ")
              (clim:with-text-face (stream :italic)
                (format stream "~(~A~)~%" feature))))
          (when selected-realop
            (format stream 
		    "~%The currently selected realization operator is: ")
            (clim:with-text-face (stream :italic)
              (format stream "~A~%" selected-realop)))
	  
	  (kpml-i-terpri stream)
	  (setf op1 (clim:accept 
		     'clim:symbol :stream stream
		     #+lispworks :view 
		     #+lispworks clim:+textual-dialog-view+
		     :prompt "This requires a grammatical function"
		     :default op1))
	  #+ignore(setf op1 (if (and op1 (string= op1 ""))
			        nil
		      (intern (string-upcase op1) "KPML")))
	  (kpml-i-terpri stream)
	  (setf op2
	        (cond ((or (eq (realization-op-type rs-op) :fu-fu))
		       ;; this is for rs-ops with arg-pattern (:fu :fu)
                       (format stream 
			       "~2%~A requires a second grammmatical function." 
			       rs-op)
                       (kpml-i-terpri stream)
		       (clim:accept 'clim:string :stream stream
			            #+lispworks :view 
				    #+lispworks clim:+textual-dialog-view+
			            :prompt "Second grammatical function"
			            :default (string op2)))
		      ((or (eq (realization-op-type rs-op) :fu-fe))
		       ;; this is for rs-ops with arg-pattern (:fu :fe)
                       (format 
		        stream "~2%~A also requires a grammmatical feature." 
			rs-op)
                       (kpml-i-terpri stream)
		       (clim:accept 'clim:string :stream stream
	                            #+lispworks :view 
				    #+lispworks clim:+textual-dialog-view+
			            :prompt "Grammatical feature"
			            :default (string op2)))
		      ((or (eq (realization-op-type rs-op) :fu-l))
		       ;; this is for rs-ops with arg-pattern (:fu :l)
                       (format 
		        stream "~2%~A also requires a lexical item name." 
			rs-op)
                       (kpml-i-terpri stream)
		       (clim:accept 'clim:string :stream stream
	                            #+lispworks :view 
				    #+lispworks clim:+textual-dialog-view+
			            :prompt "Lexical item name"
			            :default (string op2)))
		      ;; this mops up arg-patterns (:fu)
		      (t 
		       nil)))
	  (setf op2 (if (and op2 (string= op2 ""))
			nil
		      (intern (string-upcase op2) "KPML")))
	  (format 
	   stream 
	   "~2%The current realization statement created so far is: ~2%")
	  (clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
	    (format stream "(~A ~A~@[ ~A~])" rs-op op1 op2))
	  (kpml-i-terpri stream)
          (case (realization-op-type rs-op)
            ((:fu-fe :fu-l :fu-fu)
             (cond ((and rs-op op1 op2)
                    (format stream "~%Realization statement complete.")
                    (setf *constructed-rs* (list rs-op op1 op2)))
                   (t 
                    (incomplete)
                    nil)))
            (:fu
             (cond ((and rs-op op1)
                    (format stream "~%Realization statement complete.")
                    (setf *constructed-rs* (list rs-op op1)))
                   (t
                    (incomplete)
                    nil)))
            (otherwise
             (incomplete)
             nil))
          (setf rs (list selected-realop op1 op2)))))))

(defun STARTUP-RS-BULDER (feature default)
  (let ((rs-frame
         (clim:make-application-frame
             'rs-building-frame
           :pretty-name (concatenate 'string
			             "Realization statement maker (feature: "
			             (string feature) ")")
           :left 100 :top 20
           :width 450 :height 400)))
    (declare (special *rs-selection-made* *constructed-rs* *rs-process*))
    (setf *rs-selection-made* nil)
    (setf *constructed-rs* nil)

    (setf (slot-value rs-frame 'rs) default)
    (setf (slot-value rs-frame 'selected-realop)
          (if default (first default) 'kpml::insert))
    (setf (slot-value rs-frame 'feature) feature)
    
    (setf *rs-process* 
          (kpml-i::process-run-function 
           "KPML-RS-BULDER" #'clim:run-frame-top-level 
           rs-frame))
    
    ;; note that the following is really necessary in Lispworks to let 
    ;; any other process get a look-in...
    (loop until (or *rs-selection-made*
                    #+lispworks(equal (mp:process-state *rs-process*) :killed)
		    #-lispworks T)
	do (sleep 1))

    (case *rs-selection-made* 
      (:no (setf *constructed-rs* default))
      (:yes *constructed-rs*)
      (otherwise
       (setf *constructed-rs* default)))))

;;; ----------------------------------------------------------------------
;;; Commands to accept or quit...
;;; ----------------------------------------------------------------------

(define-rs-building-frame-command
 (com-ACCEPT-RS :menu T :name "Accept")
 ()
  (declare (special *rs-selection-made*))
  (setf *rs-selection-made* :yes)
  (clim:frame-exit clim:*application-frame* 
		   #+lispworks :destroy #+lispworks T))

(define-rs-building-frame-command
 (com-ABORT-SELECTION-RS :name "Abort" :menu T)
 ()
  (declare (special *rs-selection-made*))
  (setf *rs-selection-made* :no)
  (clim:frame-exit clim:*application-frame* 
		   #+lispworks :destroy #+lispworks T))

(defmacro BUILD-RS-OPERATION-COMMANDS ()
  `(progn
     ,@(loop for command 
	   in (sort (copy-list *public-realization-ops*) #'string<)
	   collect
	     `(define-rs-building-frame-command
		  (,(intern
		     (concatenate
			 'string
		       "COM-RS-"
		       (string command))
		     "KPML")
		   :menu T 
		   :name ,(string-capitalize (string command)))
		  ()
		(with-slots (selected-realop) clim:*application-frame*
		  (setf selected-realop ',command))))))

(build-rs-operation-commands)




