(in-package "KPML")

;;; File: system-popups.lisp
;;; John: Ober-Ramstadt, Feb97.
;;;
;;; ----------------------------------------------------------------------
;;; Adds a graphical view of systems, including entry conditions,
;;; that can also be used as a place for editing/creating systems.
;;; Can therefore be used instead of the Emacs editing interface 
;;; by those who are not familiar with Emacs or independently of
;;; running KPML from within Emacs. This forms a pair with the
;;; file system-popups-interface.lisp. Current file contains all
;;; the more KPML related functions.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; 2.0.57
;;; 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. The following provides a flag to switch to
;;; an extra cautious version of the realization statement menu that
;;; can be used under Lispworks.
;;; ----------------------------------------------------------------------

(defvar *CAUTIOUS-RS-DIALOG-BOX-MODE* #+lispworks T #-lispworks nil)

;;; ----------------------------------------------------------------------
;;; Following exporter updated (1.1) so that it does not rely on the
;;; Lisp compiler being present and to include region, comments, chooser...
;;; ----------------------------------------------------------------------

(defun EXPORT-SKELETON-SYSTEM (created-system)
  (let ((type (if (> (length (kpml-i::skeleton-system-outputs created-system))
		     1)
		  :system
		:gate)))
    (load-ml-system
     `(:name ,(list curlan (kpml-i::skeleton-system-name created-system))
	     :inputs ,(kpml-i::skeleton-system-inputs created-system)
	     :outputs ,(kpml-i::skeleton-system-outputs created-system)
	     :chooser ,(kpml-i::skeleton-system-chooser created-system)
	     :region ,(kpml-i::skeleton-system-region created-system)
	     :comments ,(kpml-i::skeleton-system-comments created-system)
	     :date ,(time-stamp))
     type)
    ;; 2.0.36 change the name of the window if appropriate
    (kpml-i::rename-current-window 
     (kpml-i::system-editing-window-name 
      (kpml-i::skeleton-system-name created-system)))
    ;; and protocol the edit....
    (protocol-edit
     (systemic-display (kpml-i::skeleton-system-name created-system)
		       :object-type :system :stream nil))
    T))

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

(defun READ-AN-ENTRY-CONDITION (system-inputs)
  (declare (special kpml-i::input-error))
  (multiple-value-bind (val error)
      (ignore-errors
       (let ((*package* (find-package "KPML")))
	 (read-from-string system-inputs)))
    (declare (ignore error))
    (unless val
      (setf kpml-i::input-error T)
      (throw 'kpml-i::ec-entry-error T))
    val))

;;; ----------------------------------------------------------------------
;;; Working menu for constructing realization statements. Would work
;;; better with more detail in the realization definition macro.
;;; (such as in the 1.1 definition macro above).
;;; 2.0 made to be more self-explanatory for the new user...
;;; 2.0.55 we make a very cautious menu also available.
;;; ----------------------------------------------------------------------

(defun BUILD-REALIZATION-STATEMENT-MENU (feature stream &key (default nil))
  (declare (special *constructed-rs*))
  (if *cautious-rs-dialog-box-mode*
      (progn
	(startup-rs-bulder feature default)
	(values *constructed-rs*))
    (real-build-realization-statement-menu feature stream :default default)))

(defun REAL-BUILD-REALIZATION-STATEMENT-MENU 
    (feature stream &key (default nil))
  (let ((rs-op (if default (first default) 'insert))
	(op1 (if default (second default) nil))
	(op2 (if default (third default) nil))
        (result 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:accepting-values
	  (stream :own-window kpml-i::*wide-own-window*
		  :scroll-bars :vertical
		  :resynchronize-every-pass t
		  :label (concatenate 'string
			   "Realization statement maker (feature: "
			   (string feature) ")")
		  :exit-boxes 
		  '((:exit "Click here to accept")(:abort "Abort")))

	(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: ~(~A~)...~%" feature)))

	  (clim:with-text-style (stream kpml-i::*sans-serif--roman--10*)
	    (setf rs-op
	      (clim:accept 
	       `(clim:member-sequence ,*public-realization-ops*)
	       :stream stream
	       :view #+lispworks clim:+textual-dialog-view+
	       #-lispworks 'clim:list-pane-view
	       :prompt "You must select a realization operator"
	       :default rs-op))
	    (kpml-i-terpri stream)(kpml-i-terpri stream)
	    (setf op1 (clim:accept 
		       'clim:string :stream stream
		       #+lispworks :view #+lispworks clim:+textual-dialog-view+
		       :prompt "and also a grammatical function name"
		       :default (string op1)))
	    (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 
			   "~%The realization opertor ~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 "Type its name here"
			        :default (string op2)))
		  ((or (eq (realization-op-type rs-op) :fu-fe))
		   ;; this is for rs-ops with arg-pattern (:fu :fe)
                   (format stream 
			   "~%The realization operator ~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 "Type its name here"
			        :default (string op2)))
		  ((or (eq (realization-op-type rs-op) :fu-l))
		   ;; this is for rs-ops with arg-pattern (:fu :l)
                   (format stream 
			   "~%The realization operator ~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 "Type its name here"
			        :default (string op2)))
		  ;; this mops up arg-patterns (:fu)
		  (t 
		   nil)))
      (setf op2 (if (and op2 (string= op2 ""))
		    nil
		  (intern (string-upcase op2) "KPML")))
      ;;(clim:stream-set-cursor-position stream 130 340)
      (format stream 
	      "~%The current realization statement created so far is:")
      (clim:with-text-style (stream kpml-i::*sans-serif--bold--10*)
        (format stream "(~A ~A~@[ ~A~])" rs-op op1 op2))
      (kpml-i-terpri stream)
      (setf result
	(case (realization-op-type rs-op)
	  ((:fu-fe :fu-l :fu-fu)
	   (cond ((and rs-op op1 op2)
		  (format stream "~%Realization statement complete.")
		  (list rs-op op1 op2))
		 (t 
		  (incomplete)
		  nil)))
	  (:fu
	   (cond ((and rs-op op1)
		  (format stream "~%Realization statement complete.")
		  (list rs-op op1))
		 (t
		  (incomplete)
		  nil)))
	  (otherwise
	   (incomplete)
	   nil)))))
      result)))

;;; ----------------------------------------------------------------------
;;; 2.1
;;; A make a new chooser with specified range of outputs function to be
;;; sure that everything ends up in the right package...
;;; ----------------------------------------------------------------------

(defun MAKE-NEW-CHOOSER-WITH-NAME-AND-OUTPUTS (system-name outputs)
  (let ((chooser-name 
         (intern (concatenate 'string "NEW-" (string system-name) "-CHOOSER") "KPML")))
    (load-ml-chooser 
     `(:name ,chooser-name
       :definition ((ask (inquiry-q parameter)
                         ,@(loop for o in outputs
                                 as i from 1
                                 collect
                                 `(,(intern (format nil "RESPONSE~A" i) "KPML")
                                   (choose ,(second o))))))
       :date ,(time-stamp)))
    chooser-name))


