(in-package "KPML-I")

;;; File: system-popups-interface.lisp
;;; John: Ober-Ramstadt, Jan97.
;;;
;;; 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.
;;;
;;; (Released as an experimental option as KPML-1.0.33
;;;
;;; 1.0.36 : editing functionality added.
;;; 1.0.38 : full mouse sensitivity and dependents following added.
;;; 1.1    : uses the systemic graph node structures to follow 
;;;          1.1 resource graphing
;;; 2.0    : Lispworks compatibility added (which generally means that
;;;          some things don't work...)
;;; 2.1    : protected from careful-graphing mode...
;;;
;;; Patches 2.0.9, 2.0.35, 2.0.51
;;;
;;; Adds some more options to the KPML-provided system editing options
;;; and resource graphing options...  October 1998, Edinburgh.
;;;
;;; and (2.0.35) corrects the set region ineffectivity.
;;; more of 2.0.9 is now under 2.0.28.
;;; 2.0.51 adds explicit chooser disablement.
;;;
;;; 2.1    : user levels: don't do a feature-function definition check
;;;          for novices...
;;;
;;; 4.0    : was messing up realization operations with more than
;;;          2 parameters. Displayed correctly but then truncated
;;;          in the lower realization operation pane.
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Start proper...
;;; ----------------------------------------------------------------------

(defvar *inter-node-features* 40)
(defvar *inter-gr-features* 2)
(defvar *brace-distance* 5)

(defvar *cut-realization-statement* nil)

(defvar *default-region-name* '|new-region|)

(clim:define-presentation-type gr-system-rs ())
(clim:define-presentation-type gr-system-feature () :inherit-from 'feature)
(clim:define-presentation-type gr-entry-condition () :inherit-from 'feature)
(clim:define-presentation-type gr-system ())

(clim:define-presentation-type rs-operator ())

;;; ----------------------------------------------------------------------
;;; While working and editing, a copy of the system is kept in the following
;;; structure. Only when finished is this exported to be accepted by the
;;; rest of the system as part of the loaded resources.

(defstruct SKELETON-SYSTEM
  (inputs nil)
  (outputs nil)
  (name nil)
  (chooser nil)
  (editor nil)
  (date nil)
  (region nil)
  (comments nil))

;;; ----------------------------------------------------------------------
;;; 2.0.28
;;; (2.0.9 folded in, 2.0.5 made redundent)
;;;
;;; Modifications to system editing functions so that the system editor
;;; frame and dependents created with that frame can note where they
;;; were started from. If they are started from a system network graph,
;;; exporting a change then updates that graph.
;;;
;;; 2.0.28 had to add a slot to the frame...
;;; ----------------------------------------------------------------------

(clim:define-application-frame SYSTEM-EDITOR-FRAME ()
  ((created-system :initform
		   (make-skeleton-system
		    :name 'SYSTEM-NAME
		    :inputs 'feature-0
		    :outputs '(feature-1 feature-2 feature-3)))
   (modified :initform nil)
   (rs-set :initform nil)
   (feature :initform nil)
   (used-features :initform nil)
   (used-functions :initform nil)
   (inserted-functions :initform nil)
   (moved-ec-features :initform nil)
   (calling-frame :initform nil)      ;; 2.0.28 calling frame for updating
   )
  (:top-level (clim:default-frame-top-level  :prompt kpml-prompt-function))
  (:menu-bar nil)
  (:command-table 
   (system-editor-frame
    :inherit-from (kpml-resource-inspector)))
  (:panes (system-pane :application
		       :incremental-redisplay T
		       :display-function 'created-system-displayer
		       :foreground resource-graph-fg
		       :initial-cursor-visibility :inactive
		       :scroll-bars :vertical
		       :background resource-graph-bg
		       :text-style *sans-serif--bold--10*)
	  (functions   :application
		       :scroll-bars :vertical
		       :display-function 'undefined-function-displayer
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--8*)
	  (features    :application
		       :incremental-redisplay T
		       :display-function 'undefined-feature-displayer
		       :scroll-bars :vertical
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--8*)
	  (rs-set      :application
		       :display-function 'rs-set-displayer
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
	  (menu        :command-menu
		       :max-height 80
		       :height 80
		       :foreground menu-fg
		       :background menu-bg
		       :text-style *menu-font*))
  (:layouts 
   (rs-editing
    (clim:vertically ()
      menu
      (1/2 system-pane)
      (:fill rs-set)))
   (default
       (clim:vertically ()
         menu
	 (:fill system-pane)))
   (undefineds
    (clim:vertically ()
      menu
      (1/2 (clim:horizontally ()
	     (4/6 system-pane)
	     (:fill (clim:vertically ()
		      (1/2 features)
		      (:fill functions)))))
      (:fill rs-set))))
  (:command-definer t))


;;; ----------------------------------------------------------------------
;;; Following keeps a hold of what functions and features are used
;;; in the working system in order to know which of these are not
;;; yet defined. When undefined features/functions appear, they appear
;;; in additional panes.

(defmethod UNDEFINED-FUNCTION-DISPLAYER ((frame system-editor-frame) stream)
  (with-slots (used-functions inserted-functions) clim:*application-frame*
    (clim:with-text-style (stream '(nil (:bold :italic) :larger))
	(format stream "Uninserted functions"))
      (loop for f in used-functions
	  unless (or (kpml::who-can-insert f)
		     (member f inserted-functions :test #'equal))
	  do
	    (format stream "~%~@(~A~)" f))))

(defmethod UNDEFINED-FEATURE-DISPLAYER ((frame system-editor-frame) stream)
  (with-slots (used-features) clim:*application-frame*
    (clim:updating-output (stream :unique-id used-features)
      (clim:with-text-style (stream '(nil (:bold :italic) :larger))
	(format stream "Undefined features"))
      (loop for f in (remove 'kpml::start used-features)
	  unless (kpml::who-has-as-output f)
	  do 
	    (clim:updating-output (stream :cache-value f)
	      (format stream "~%~:(~A~)" f))))))


;;; Following does not yet work under Harlequin Lispworks. Changing
;;; the layout blows the window handler away...
;;; 2.1 user level added. Only do check for level 2 and greater.

(defun CHECK-FEATURE-FUNCTION-DEFINITIONS ()
  #+(and :kpml-level>= :kpml-l2)
  (flet ((undefined-features-or-functions-layout ()
	   (setf (clim:frame-current-layout clim:*application-frame*)
	     'undefineds)
	   (return-from CHECK-FEATURE-FUNCTION-DEFINITIONS nil)))
    #-lispworks
    (with-slots (created-system used-features used-functions) 
	clim:*application-frame*
      (register-features-and-functions)
      (loop for f in used-features 
	  unless (kpml::who-has-as-output f)
	  do (undefined-features-or-functions-layout))
      (loop for f in used-functions
	  unless (kpml::who-can-insert f)
	  do (undefined-features-or-functions-layout))
      (setf (clim:frame-current-layout clim:*application-frame*) 
	(if (eq (clim:frame-current-layout clim:*application-frame*)
		'rs-set)
	    'rs-set
	  'default))))
  nil)
		   
(defun REGISTER-FEATURES-AND-FUNCTIONS ()
  "scan the working definition for features and function use"
  (with-slots (created-system used-features used-functions inserted-functions) 
      clim:*application-frame*
    (labels ((register-ec-features (ec)
	       (if (symbolp ec)
		   (pushnew ec used-features)
		 (loop for e in (cdr ec)
		     when (consp e)
		     do (register-ec-features e)
		     else 
		     do (pushnew e used-features))))
	     (register-rs-usage (rs-set)
	       (loop for rs in (cddr rs-set)
		   when (equal (first rs) 'kpml::insert)
		   do (pushnew (second rs) inserted-functions)
		   else
		   do 
		   (pushnew (second rs) used-functions)
		   (case (kpml::realization-op-type (first rs))
		     (:fu-fe (pushnew (third rs) used-features))
		     (:fu-fu (pushnew (third rs) used-functions))))))
      (setf inserted-functions nil)
      (setf used-features nil)
      (setf used-functions nil)
      (register-ec-features (skeleton-system-inputs created-system))
      (mapcar #'register-rs-usage 
	      (skeleton-system-outputs created-system)))))


;;; ----------------------------------------------------------------------
;;; The method for displaying the working system in a systemic-like
;;; form.
;;;
;;; 2.1 protected from the careful-graphing mode option for resource
;;;     graphing in general...
;;; 4.0 add the usual explicit graphical reminder when the system
;;;     is disabled... Usual CLIM stuff of taking out a macro so
;;;     that we can easily conditionalize stuff...
;;; ----------------------------------------------------------------------

(defmethod CREATED-SYSTEM-DISPLAYER ((frame system-editor-frame) stream)
  (macrolet 
   ((graph-it
     ()
     ;; 2.0 moving the updating output to here works better for
     ;;     Lispworks which otherwise tended to lose the entry
     ;;     condition in the redisplay...
     '(clim:updating-output (stream :unique-id starting-points)
      (when root-point
	(clim:stream-set-cursor-position 
	 stream 
	 (+ (first root-point) 10)
	 (+ (second root-point) 10)))
      (clim:format-graph-from-roots
       starting-points
       #'(lambda (node s)                                 ;; printer
	   (clim:updating-output (s :cache-value node)
	     (print-gr-system-nodes node s)))
       #'(lambda (node)                                   ;; descendents
	      (if (eq (systemic-graph-node-type node) 'kpml::system)
		  (mapcar #'(lambda (x) 
			      (make-systemic-graph-node 
			       :type 'kpml::feature 
			       :value x))
			  (skeleton-system-outputs system-skeleton))
		nil))
       :generation-separation 20
       :within-generation-separation 20
       :arc-drawer #'single-systemic-arc-drawer          ;; 2.1
       :cutoff-depth 2
       :merge-duplicates t
       :duplicate-test #'equal
       :move-cursor T
       :orientation :horizontal
       :stream stream))))
   (let* ((system-skeleton 
	   (slot-value clim:*application-frame* 'created-system))
	  (moved-ec-features 
	   (slot-value clim:*application-frame* 'moved-ec-features))
	  (system-name (skeleton-system-name system-skeleton))
	  (starting-points 
	   (list (make-systemic-graph-node :type 'kpml::system
					  :value system-name)))
	  (root-point nil)
	  (*show-system-names* T))
     (setf root-point
	   (ec-graph system-name 
		     (skeleton-system-inputs system-skeleton) 
		     stream moved-ec-features))

     ;; 4.0
     (if (member system-name kpml::*disabled-systems* :key #'car)
	 (clim:with-drawing-options 
	  (stream :ink *grey*)
	  (graph-it))
       (graph-it))
     )))


;;; ----------------------------------------------------------------------
;;; A simple arc drawer that does not try and do anything too fancy...
;;; (because we have only one system here to graph)
;;; ----------------------------------------------------------------------

(defun SINGLE-SYSTEMIC-ARC-DRAWER (stream from-node to-node x1 y1 x2 y2
			    &rest drawing-options
			    &key path draw-nodes (with-name nil)
			    &allow-other-keys)
  (declare (ignore drawing-options draw-nodes))
  (if (systemic-graph-node-p from-node)
      (let* ((object (systemic-graph-node-value from-node))
	     (type   (systemic-graph-node-type from-node))
	     (dashed-p
	      (and *graph-display-mode*
		   *dashed-shortcuts*
		   (systemic-graph-node-p to-node)
		   (if (rassoc (systemic-graph-node-value to-node)
			      *path-shortcuts*) T nil))))
	(case type
	  ((kpml::feature kpml::path-f)
	   (if (feature-on-generation-path-p object)
	       (clim:with-drawing-options 
		(stream :ink clim:+magenta+)
		(connect-feature-with-system stream x1 y1 x2 y2 path))
	     (connect-feature-with-system stream x1 y1 x2 y2 path)))
	  ((kpml::system kpml::path-s)
	   (if path
	       (let ((i-x (first path))
		     (i-y (second path)))
		 (make-system-shape stream from-node x1 y1 i-x i-y
				    :with-name T)
		 (path-drawer stream i-x i-y `(,@(cddr path) ,x2 ,y2)))
	     (make-system-shape stream from-node x1 y1 x2 y2
				:with-name with-name)))))))




(defun PRINT-GR-SYSTEM-NODES (object+type stream)
  (cond ((systemic-graph-node-p object+type)
	 (let ((object (systemic-graph-node-value object+type))
	       (type (systemic-graph-node-type object+type)))
	   (cond ((eq type 'kpml::system)
		  (clim:with-output-as-presentation 
		      (stream object 'gr-system)
		    (format stream ":")))
		 (t		
		  (present-gr-systemic-feature-as-node stream object))
		 )))
	(t
	 (format stream "~a" object+type))
	))

;;; ----------------------------------------------------------------------
;;; Following does the job for the system skeletons maintained until
;;; the user exports the working definition...
;;; ----------------------------------------------------------------------

(defun FETCH-REALIZATION-STATEMENTS-OF-SKELETON-FEATURE (feature)
  (let* ((outputs (skeleton-system-outputs 
		   (slot-value clim:*application-frame* 'created-system))))
    (loop for o in outputs
	when (equal (second o) feature)
	do
	  (return-from fetch-realization-statements-of-skeleton-feature
	    (cddr o)))))

(defun PRESENT-GR-SYSTEMIC-FEATURE-AS-NODE (stream object)		      
  ;; 2.0.34 contribution folded in, also from system-popups...
  (let* ((*standard-output* stream)
	 (kpml::*print-right-margin* 
	  (+ kpml::*rs-box-width* 15))  ;; 2.0.34 made longer...
	 (feature (second object))
	 (rs-set (fetch-realization-statements-of-skeleton-feature feature)))
    (clim:with-output-as-presentation
	(stream feature 'gr-system-feature)
      (clim:with-text-style (stream kpml-i::*sans-serif--bold--12*)
	(if (feature-on-generation-path-p feature)
	    (clim:with-drawing-options 
		(stream :ink clim:+magenta+)
	      (format stream "~%~0T~(~a~)" feature))
	  (format stream "~%~0T~(~a~)" feature))))
    (when rs-set
      (clim:with-output-as-presentation
	  (stream (cons feature rs-set) 'gr-system-rs)
	(clim:with-text-style  (stream kpml-i::*fix--bold--8*)
	  (kpml-i-terpri stream)
	  #-(or acl3.0 lispworks)
	  (pprint-logical-block 
	   (nil rs-set :prefix "     ")
	   (loop 
	     (let ((rs (pprint-pop)))
	       (kpml::pprint-single-rs rs)
	       (write-char #\.)
	       (pprint-exit-if-list-exhausted)
	       (pprint-newline :fill)))
	   )
	  #+(or acl3.0 lispworks)
	  (loop for rs in rs-set
		do 
		(format t "   ")
		(kpml::nonansi-pprint-single-rs rs)
		(format t "~%")))))))

#-lispworks
(define-system-editor-frame-command 
    (com-SEF-BLANK-SPACE-OPTIONS :name t)
    ()
  (setf (clim:frame-current-layout clim:*application-frame*) 'default))

(clim:define-presentation-to-command-translator 
    system-editing-blank-space-options
    (clim:blank-area com-sef-blank-space-options system-editor-frame
		     :documentation "Back to system being edited")
  (x y)
  (declare (ignore x y))
  (values))

;;; ----------------------------------------------------------------------
;;; 2.0.19 a call to the following new function can also be placed in the
;;;        startup function.
;;; 4.0    changed to give more immediately recogniseable / distinguishable
;;;        names.
;;; ----------------------------------------------------------------------

(defun SYSTEM-EDITING-WINDOW-NAME (system)
  (concatenate 'string
    (string system)
    ":"
    (if (kpml::fetch-system-region system)
	(concatenate 
	    'string " [region: " 
	    (string (kpml::fetch-system-region system)) "]")
      "")
    " [language: " (string kpml::curlan) "]"
    (if (kpml::fetch-system-patch-status system) "  (***patched***)" ""))
  )

;;; ----------------------------------------------------------------------
;;; Basic startup functions... 
;;; 3.1 these now just call the generically created frame startups
;;; ----------------------------------------------------------------------

(defun CREATE-A-SYSTEM-EDITING-GRAPH 
    (system &optional (offset nil)(calling-frame nil))
  (let* ((window-name (system-editing-window-name system)))
    (create-a-system-editing-graph-internal
     system offset calling-frame window-name :frame-tool-label system)))

(defun CREATE-A-NEW-SYSTEM-EDITING-GRAPH 
    (system-name entry-condition region
     &optional (features '((0.5 feature1) (0.5 feature2)))
	       (calling-frame nil))
  (let* ((window-name (concatenate 'string
		       "system-editor: "
		       (if system-name (string system-name)
			 "NEW SYSTEM"))))
    (create-a-new-system-editing-frame
     system-name entry-condition region features calling-frame)))

;;; ----------------------------------------------------------------------
;;; The menu commands for a graphical system display window...

(define-system-editor-frame-command
    (com-QUIT-SYSTEM-EDITOR :name t :menu "Quit")
    ()
    (with-slots (modified) clim:*application-frame*
       (if
	   (and modified
		(eq (startup-user-response-frame
		     '("Modified system has not been saved. Save it first?"))
		    :yes))
	   (com-export-gr-system)
         (close-a-window clim:*application-frame*))))


(define-system-editor-frame-command
    (com-NEW-GR-SYSTEM :name t :menu "Make new system")
    ()
  (setf (slot-value clim:*application-frame* 'created-system) 
    (make-skeleton-system :name nil
			  :outputs nil
			  :inputs nil
			  :chooser nil
			  :region *default-region-name*)))

(define-system-editor-frame-command
    (com-RENAME-GR-SYSTEM :name t :menu "Rename system")
    ()
  ;; 2.0.19, 2.0.36
  ;; a little addition to system renaming in the system editor.
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (with-slots (modified created-system) clim:*application-frame*
       (clim:accepting-values
	  (stream :own-window *own-window*
		  :scroll-bars :horizontal
		  :resynchronize-every-pass t
		  :label (concatenate 'string "New name for system: "
				      (string
				       (skeleton-system-name created-system)))
		  :exit-boxes '((:exit "Click here to accept name")
				(:abort "Click here to cancel")))
	(setf (skeleton-system-name created-system)
	  (intern
	   (string-upcase
	    (clim:accept 
	     'clim:string :stream stream
	     #+lispworks :view #+lispworks clim:+textual-dialog-view+
	     :prompt "System name"
	     :default (string 
		       (skeleton-system-name created-system))))
	   "KPML"))
	;; 2.0.19: we've changed the name, so change the window name
	;;         accordingly (if we can...)
	(rename-current-window 
	 (system-editing-window-name-from-skeleton created-system))
	(setf modified T)))))

(define-system-editor-frame-command
    (com-RECHECK-GR-FEATURE-USE :name t :menu "Recheck usage")
    ()
  (check-feature-function-definitions))

  ;; ----------------------------------------------------------------------
  ;; 3.2.16
  ;;   make the confirmation dialog for modification when not in versioning
  ;;   mode go away in novice mode.
  ;; ----------------------------------------------------------------------
	
(define-system-editor-frame-command
  (com-EXPORT-GR-SYSTEM :name t :menu "Export")
  ()
  (with-slots (created-system modified calling-frame) clim:*application-frame*
    (cond ((null (skeleton-system-name created-system))
	   (clim:notify-user clim:*application-frame*
			     "No system name defined."))
	  ((null (skeleton-system-inputs created-system))
	   (clim:notify-user clim:*application-frame*
			     "No entry conditions defined."))
	  ((null (skeleton-system-outputs created-system))
	   (clim:notify-user clim:*application-frame*
			     "No output features defined."))
	  (t
	   (when (or
		  (member :resource-patches kpml::*loading-saving-profile*)
		  ;; 3.2.16
		  #-(and :kpml-level>= :kpml-l1) T
		  #+(and :kpml-level>= :kpml-l1)
		  (eq (startup-user-response-frame
		       '("Patch versioning is not activated. Do you really want to change the loaded resources?"))
		      :yes))
	     (kpml::export-skeleton-system created-system)
	     ;; 2.0.28
	     (when calling-frame
	       (let ((clim:*application-frame* calling-frame))
		 (clim:redisplay-frame-pane calling-frame 'graph)))
	     (setf modified nil))))))

(define-system-editor-frame-command
    (com-MAKE-NEW-FEATURE :name t :menu "Add new feature")
    ()
  (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	 (system-skeleton 
	  (slot-value clim:*application-frame* 'created-system))
	 (system-name (skeleton-system-name system-skeleton))
	 (system-outputs (skeleton-system-outputs system-skeleton))
	 (p (float (/ 1 (1+ (length system-outputs)))))
	 (new-feature nil))
    (clim:accepting-values
	(stream :own-window *own-window*
		:scroll-bars :horizontal
		:resynchronize-every-pass t
		:label (concatenate 'string "New feature for system: "
				    (string system-name)) 
                #+lispworks :width #+lispworks 300 
                #+lispworks :height #+lispworks 200
		:exit-boxes '((:exit "Click here to accept feature")
			      (:abort "Click here to cancel")))
      (setf new-feature
	(intern 
	 (string-upcase
	  (clim:accept 'clim:string :stream stream
		       #+lispworks :view #+lispworks clim:+textual-dialog-view+
		       :prompt "Feature name"
		       :default (string new-feature)))
	 "KPML"))
      (kpml-i-terpri stream)
      #+lispworks (kpml-i::dialog-end-spacing))
    (when new-feature
      (setf (slot-value clim:*application-frame* 'modified) T)
      (setf (skeleton-system-outputs 
	     (slot-value clim:*application-frame* 'created-system))
	(append
	 (mapcar #'(lambda (x) `(,p ,@ (rest x))) system-outputs)
	 `((,p 
	    ,new-feature))))
        #+lispworks(clim:redisplay-frame-pane clim:*application-frame* 
					      'system-pane :force-p T))))
	 
(define-system-editor-frame-command
    (com-EDIT-ENTRY-CONDITION :name t :menu "Edit entry condition")
    ()
  (let* ((stream 
	  (clim:get-frame-pane clim:*application-frame* 'system-pane))
	 (system-skeleton 
	  (slot-value clim:*application-frame* 'created-system))
	 (system-name (skeleton-system-name system-skeleton))
	 (system-inputs 
	  (format nil "~A" (skeleton-system-inputs system-skeleton)))
	 (input-error nil))
    (declare (special input-error))
    (loop while
	  (catch 'ec-entry-error
	    (clim:accepting-values
		(stream :own-window T ; *wide-own-window*
			:scroll-bars :horizontal
			:resynchronize-every-pass t
                        #+lispworks :width #+lispworks 400
                        #+lispworks :height #+lispworks 200
                        :right-margin 400
                        :bottom-margin 200
			:label (concatenate 
				   'string "Edit entry condition for system: "
				   (string system-name)) 
			:exit-boxes '((:exit "Click here to accept")
				      (:abort "Click here to cancel")))
	      (when input-error
		(clim:with-text-style (stream *sans-serif--bold--10*)
		  (format 
		   stream "~%Input expression error: edit to correct~%")))
	      (setf system-inputs
		(clim:accept 
		 'clim:string :stream stream
		 #+lispworks :view #+lispworks clim:+textual-dialog-view+
;; 2.1 the following looks much better, but I don't know how to get
;;     the contents of the field yet...
;;		 #-lispworks :view 
;;		 #-lispworks '(clim:text-editor-view :nlines 4)
		 :insert-default T
		 :prompt "Entry condition"
		 :default system-inputs))
	      (kpml-i-terpri stream)
	      #+lispworks (kpml-i::dialog-end-spacing))
	    (setf (slot-value clim:*application-frame* 'modified) T)
	    (setf (skeleton-system-inputs system-skeleton)
	      (kpml::read-an-entry-condition system-inputs))
	    NIL))
    (check-feature-function-definitions)))


;; 4.0
(define-system-editor-frame-command
    (com-DISABLE-ENABLE-TOGGLE :name t :menu "Enable/Disable")
    ()
    (with-slots 
     (created-system)
     clim:*application-frame*
     (if (member (skeleton-system-name created-system) kpml::*disabled-systems* :key #'car)
	 (kpml::enable-system (skeleton-system-name created-system))
        (kpml::disable-system (skeleton-system-name created-system)))))

;;; ACLPC, ACL3.0 CLIM2.1 does not appear to know about postscript!
;;; Lispworks also... 
;;; 4.0 Postscript ok for LWW4.1+ if the right module is loaded...

#-(or lispworks4.0 (not :POSTSCRIPT-CLIM) acl3.0)
(define-system-editor-frame-command
    (com-GR-SYSTEM-POSTSCRIPT :name t :menu "Make postscript file")
    ()
  (with-slots (created-system moved-ec-features)
      clim:*application-frame*
    (let* ((system-name (skeleton-system-name created-system))
	   (filename (merge-pathnames  *default-kpml-hardcopy-directory* 
					 (make-hardcopy-filename 
					  (concatenate 'string
					    (string system-name)
					    "-"
					    (string kpml::curlan)))))
	     (starting-points `((kpml::system . ,system-name)))
	     (root-point nil))
	(declare (special root-point))
	(with-open-file 
	    (fstr filename :direction :output :if-exists :overwrite 
	     :if-does-not-exist :create)
	    (clim::with-output-to-postscript-stream 
	     (pstr fstr :multi-page (not *suitable-for-figures?*))
	     (unless *suitable-for-figures?*
		     (clim:with-text-style  
		      (pstr *fix--bold--16*)
		      (format pstr "System: ~A ~%  (Language: ~A at ~A~10%~0T"
			      (skeleton-system-name created-system)
			      kpml::curlan
			      (kpml::time-stamp))))
	     (clim:updating-output 
	      (pstr :unique-id starting-points)
	      (multiple-value-bind 
	       (x y)
	       (clim:stream-cursor-position pstr)
	       (setf root-point
		     (ec-graph 
		      system-name (skeleton-system-inputs created-system) 
		      ;; 4.0 following paras were in wrong order...
		      pstr moved-ec-features x y)))
	      
	      (when root-point
		    (clim:stream-set-cursor-position 
		     pstr
		     (first root-point)
		     (second root-point)))

	      (clim:format-graph-from-roots
	       starting-points 
	       #'print-gr-system-nodes                   ;; printer
	       #'(lambda (node)                          ;; descendents
		 (if (eq (car node) 'kpml::system)
		     (mapcar #'(lambda (x) `(kpml::feature ,x)) 
			     (skeleton-system-outputs created-system))
		   nil))
	       :generation-separation 20
	       :within-generation-separation 20
	       :arc-drawer #'single-systemic-arc-drawer
	       :cutoff-depth 2
	       :merge-duplicates t
	       :duplicate-test #'equal
	       :move-cursor T
	       :orientation :horizontal
	       :stream pstr)
	      fstr))
	    (when *auto-print* (auto-print filename))))))

(define-system-editor-frame-command
    (com-GR-SYSTEM-DISPLAY-OPTIONS :name t :menu "Display options")
    ()
  (let ((stream (clim:get-frame-pane clim:*application-frame* 'system-pane)))
    (clim:accepting-values
	(stream :own-window *own-window*
		:scroll-bars :vertical
		:resynchronize-every-pass t
		:label "Graphical System Display Modes" :exit-boxes 
		'((:exit "Click here to exit")(:abort "")))
      (setq *inter-gr-features*
	(clim:accept 'integer :stream stream
		     #+lispworks :view #+lispworks clim:+textual-dialog-view+
		     :prompt "Vertical scaling             ............"
		     :default *inter-gr-features*))
      (kpml-i-terpri stream)
      (setq *inter-node-features*
	(clim:accept 'integer :stream stream
		     #+lispworks :view #+lispworks clim:+textual-dialog-view+
		     :prompt "Horizontal scaling           ............"
		     :default *inter-node-features*))
      (kpml-i-terpri stream)
      (on-or-off kpml::*region-external-links-visible?*
		 "Region external links visible ...........")
      (kpml-i-terpri stream)
      #+lispworks (kpml-i::dialog-end-spacing))))

;;; ----------------------------------------------------------------------
;;; Following builds up a parent-child mapping for arbitrary entry 
;;; conditions to build a subgraph corresponding to entry conditions:
;;; the hashtable argument holds the associations.

(defun ENTRY-CONDITION-TO-ASSOCIATION (ec root hashtable)
  (typecase ec
    (cons
     (cond ((eq (first ec) 'kpml::and)
	    (let* ((and-node (cons 'kpml::and (gensym))))
	      (setf (gethash and-node hashtable) root)
	      (loop for ele in (rest ec)
		  when (symbolp ele)
		  do (setf (gethash 
			    (cons 'i-feature ele) hashtable) and-node)
		  else
		  when (consp ele)
		  do (entry-condition-to-association ele and-node hashtable))))
	   ((eq (first ec) 'kpml::or)
	    (let ((or-node (cons 'kpml::or (gensym))))
	      (setf (gethash or-node hashtable)  root)
	      (loop for ele in (rest ec)
		  when (symbolp ele)
		  do (setf (gethash 
			    (cons 'i-feature ele) hashtable) or-node)
		  else
		  when (consp ele)
		  do (entry-condition-to-association ele or-node hashtable))))
	   (t (kpml::warning "Ill-formed entry condition: " ec))))
    (symbol
     (setf (gethash (cons 'i-feature ec) hashtable) root))))
	 
(defun EC-GRAPH (name ec stream &optional (moved-features nil)(x-root 4)(y-root 40))
  (let ((echash (make-hash-table))              
	(terminals nil)
	(root-point nil))
    (declare (special root-point))
    (entry-condition-to-association ec name echash)  ;; build parent-child map
    (maphash #'(lambda (key value)
		 (declare (ignore value))
		 (when (eq (car key) 'i-feature) (pushnew key terminals)))
	     echash)
    (clim:stream-set-cursor-position stream x-root y-root)
    (clim:format-graph-from-roots
     terminals
     #'(lambda (node s)                                ;; printer
	 (clim:updating-output (s :cache-value (cons node moved-features))
	   (apply #'ec-node-printer
		  (list node s))))
     #'(lambda (node)                                  ;; descendents
	 (if (eq (car node) 'r-node)
	     nil
	   (let ((result (gethash node echash)))
	     (if (equal result name) (list (cons 'r-node name))
	       (list result)))))
     :generation-separation *inter-node-features*
     :within-generation-separation *inter-gr-features*
     :cutoff-depth nil
     :arc-drawer #'entry-condition-arcs
     :merge-duplicates t
     :duplicate-test #'equal
     :move-cursor nil
     :orientation :horizontal
     :stream stream)
    root-point))


(defmacro CONNECT-PATH (stream x1 y1 x2 y2 path)
  `(if ,path
       (let ((last-point (last ,path 2)))
	 (path-drawer ,stream ,x1 ,y1 ,path)
	 (clim:draw-line* ,stream 
			 (first last-point)(second last-point) ,x2 ,y2))
     (clim:draw-line* ,stream ,x1 ,y1 ,x2 ,y2)))

(defun ENTRY-CONDITION-ARCS (stream from-node to-node x1 y1 x2 y2
			     &rest drawing-options
			     &key path draw-node
			     &allow-other-keys)
  (declare (special root-point)
	   (ignore draw-node drawing-options from-node))
  (if (consp to-node)
      (case (car to-node)
	(i-feature (connect-path stream x1 y1 x2 y2 path))
	(r-node (connect-path stream x1 y1 x2 y2 path)
		(setf root-point (list x2 y2)))
	(kpml::or
	 (clim:draw-line* stream x1 y1 x2 y1)
	 (clim:draw-line* stream x2 y1 x2 y2))
	(kpml::and
	 (let ((i-x (- x2 *brace-distance*))
	       (i-y (- y2 (* (/ (- y2 y1) x2) *brace-distance*))))
	   (clim:draw-line* stream x1 y1 i-x i-y)
	   (draw-entry-brace-at stream (- x2 *brace-distance*) y2 1)))
	(t
	 (format t "~%Forgotten: ~A" to-node)))
    (connect-path stream x1 y1 x2 y2 path)))
    
     
(defun DRAW-ENTRY-BRACE-AT (stream x y size)
  "Ultra-primitive brace, until someone does it better!..."
  (declare (ignore size))
  (clim:draw-line* stream x y x (+ y 10))
  (clim:draw-line* stream x y x (- y 10))
  (clim:draw-line* stream x (+ y 10) (- x 10) (+ y 15))
  (clim:draw-line* stream x (- y 10) (- x 10) (- y 15)))

(defun EC-NODE-PRINTER (node s)
  (case (car node)
    (i-feature 
     (clim:with-output-as-presentation 
      (s (cdr node) 'gr-entry-condition)
      (if (cdr node) 
	  (macrolet 
	   ((print-feature 
	     ()
	     `(if (feature-on-generation-path-p (cdr node))
		  (clim:with-drawing-options 
		   (s :ink clim:+magenta+)
		   (format s "~A" 
			   (string-downcase (string (cdr node)))))
		(format s "~A" 
			(string-downcase (string (cdr node)))))))
	   (if (and kpml::*region-external-links-visible?*
		    (not 
		     (equal (kpml::fetch-system-region
			     (first (kpml::who-has-as-output (cdr node))))
			    (skeleton-system-region
			     (slot-value clim:*application-frame* 
					 'created-system)))))
	       (clim:with-text-style  
		(s *sans-serif--italic--8*)
		(print-feature))
	     (print-feature)))
	(clim:with-drawing-options 
	 (s :ink clim:+red+)
	 (clim:with-text-face 
	  (s '(:bold :italic))
	  (format s "not yet attached"))))))
    ((kpml::and kpml::or)
     nil)
    (r-node
     nil)))

;;; ----------------------------------------------------------------------
;;; Following does a very basic curly bracket imitation,
;;; until someone does it better... (Not really working, don't get
;;; interaction from the various CLIM translations, scalings, etc.;
;;; left for now...)

(defun BRACE (p x y &optional (mx 1)(my 1)(right nil))
  (clim:with-drawing-options 
      (p :ink clim:+black+
	 :line-thickness 2
	 :transformation 
	 (if right
	     (clim:make-reflection-transformation* 10 10 10 60)
	   clim:+identity-transformation+))
    (clim:with-translation (p x y)
      (clim:with-scaling (p mx my)
	(clim:draw-lines* 
	 p 
	 '(0 0 5 5 5 5 10 10 10 10 10 60 10 60 5 65 5 65 0 70) 
	 :line-thickness 2)))))

;;; ----------------------------------------------------------------------
;;; Actions for objects in the system graph...
;;; (i) features...
;;;
;;; 2.0.28, 2.0.29
;;; And make sure that the behaviour of noting which frame starts
;;; an editor window is also done by dependent systems also
;;; started up from the system editor (although this can involve systems
;;; that are not in the original graph...)
;;; ----------------------------------------------------------------------

(clim:define-presentation-action present-system-popup-feature
    (gr-system-feature nil system-editor-frame
		       :documentation "Editing options")
  (object)
  (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	 (calling-frame (slot-value clim:*application-frame* 'calling-frame))
	 (system-skeleton 
	  (slot-value clim:*application-frame* 'created-system))
	 (system-outputs (skeleton-system-outputs system-skeleton))
	 (choice (menu-choose
		  `(
		    ;; 2.0.9
		    ("Edit feature name" :value :edit-feature)
		    ("Remove feature" :value :remove-feature)
		    ("Add realization statement" :value :add-rs)
		    ("Yank deleted realization statement" :value :yank-rs)
		    ("Inspect dependent systems" :value :deps)
		    ("Make a dependent system" :value :make-dep)))))
    (case
     choice
     (:deps         ;; this ones for Renate!
      (let ((deps (kpml::who-has-as-input object))
	    (offset (gensym)))
	(loop for dep in deps
	      do (create-a-system-editing-graph dep offset calling-frame))))
     (:make-dep
      (create-a-new-system-editing-graph 
       nil object 
       (skeleton-system-region
	(slot-value clim:*application-frame* 'created-system))
       nil calling-frame))
     ;; 2.0.9
     (:edit-feature
      (let ((new-feature-name (edit-feature-name object)))
	(when new-feature-name
	  (setf (skeleton-system-outputs
		 (slot-value clim:*application-frame* 'created-system))
	    (loop for o in system-outputs
		when (string= (second o) (string object))
		collect `(,(first o)
			  ,new-feature-name
			  ,@(cddr o))
		else collect o)))
	(setf (slot-value clim:*application-frame* 'modified) T)
	(clim:redisplay-frame-pane clim:*application-frame* 
				   'system-pane :force-p T)))
     (:remove-feature
      (setf (skeleton-system-outputs
	     (slot-value clim:*application-frame* 'created-system))
	    (delete-if #'(lambda (x) 
			   (string= (string (second x))(string object)))
		       system-outputs))
      (setf (slot-value clim:*application-frame* 'modified) T)
      (clim:redisplay-frame-pane clim:*application-frame* 
				 'system-pane :force-p T))
     ((:add-rs :yank-rs)
      (let ((rs (if (eq choice :yank-rs)
		    *cut-realization-statement*
		  (kpml::build-realization-statement-menu object stream))))
	(when rs
	      (setf (skeleton-system-outputs 
		     (slot-value clim:*application-frame* 'created-system))
		    (loop for o in system-outputs
			  unless (string= (string (second o))(string object))
			  collect o
			  else
			  collect 
			   `( ,(first o) 
			      ,(second o) 
			      ,@ (setf (slot-value clim:*application-frame* 
						   'rs-set)
				       (append (cddr o)
					       (list rs))))))
	       (setf (slot-value clim:*application-frame* 'modified) T)
	       (clim:redisplay-frame-pane clim:*application-frame* 
					  'system-pane :force-p T)
	       (check-feature-function-definitions)
	       (when (or (eq (clim:frame-current-layout 
			      clim:*application-frame*)
			     'rs-editing)
			 (eq (clim:frame-current-layout 
			      clim:*application-frame*)
			     'undefineds))
		     (clim:redisplay-frame-pane clim:*application-frame* 
						'rs-set :force-p T))))))))


;;; ----------------------------------------------------------------------
;;; (ii) realization statements...
;;;      the entire set of realization statements is mouse sensitive as
;;;   a whole, not individually due to unfavorable interactions between 
;;;   CLIM and the pretty printer. Selecting the realization statement
;;;   set makes this the current value of the frame slot rs-set, and
;;;   opens up the realization statement pane for further editing. It
;;;   receives both the feature to which the rs-set belongs (first) and
;;;   the rs-set itself.

(clim:define-presentation-action present-system-popup-rs
    (gr-system-rs nil system-editor-frame
                  :documentation "Realization statement editor")
  (object)
  (let* ((feature (car object))
	 (rs-set (cdr object)))
    (setf (slot-value clim:*application-frame* 'rs-set) rs-set)
    (setf (slot-value clim:*application-frame* 'feature) feature)
    (setf (clim:frame-current-layout clim:*application-frame*) 
      (if (eq (clim:frame-current-layout clim:*application-frame*)
		     'undefineds) 'undefineds 'rs-editing))
    (clim:redisplay-frame-pane clim:*application-frame* 'rs-set)
    ))


;; 4.0+ here we need to be more careful about realization
;;      operations with more operands in them than just the
;;      two supported by the realization operator menu.

(defmethod RS-SET-DISPLAYER ((frame system-editor-frame) stream)
  (let ((rs-set (slot-value clim:*application-frame* 'rs-set)))
    (when (loop for rs in rs-set thereis (> (length rs) 3))
      (clim:notify-user
       clim:*application-frame*
       (format nil "Warning: this system contains non-standardized~%         realization statements and should (for now) be~%         edited in a text-based editor.")))

    (clim:formatting-table (stream :x-spacing '(2 :character))
      (loop for rs in rs-set
	  if (< (length rs) 3)
	  do 
	  ;; original code...
	  (clim:with-output-as-presentation
		(stream rs 'rs-operator)
	      (clim:formatting-row (stream)
		(clim:formatting-cell (stream)
		  (format stream "~A" (first rs)))
		(clim:formatting-cell (stream)
		  (format stream "~A" (second rs)))
		(when (third rs)
		  (clim:formatting-cell (stream)
		    (format stream "~A" (third rs))))))
	  else
	  do
	  (case (kpml::realization-op-type (first rs))
		(:fu
		 (loop for fu in (cdr rs)
		       do
		       (clim:with-output-as-presentation
			(stream (list (first rs) fu) 'rs-operator)
			(clim:formatting-row 
			 (stream)
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" (first rs)))
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" fu))))))
		((:fu-fe :fu-l)
		 (loop for fe-l in (cddr rs)
		       do
		       (clim:with-output-as-presentation
			(stream (list (first rs) (second rs) fe-l)
				'rs-operator)
			(clim:formatting-row 
			 (stream)
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" (first rs)))
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" (second rs)))
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" fe-l))))))
		(:fu-fu
		 (loop for (f1 f2) on (cdr rs)
		       when f2
		       do
		       (clim:with-output-as-presentation
			(stream (list (first rs) f1 f2)
				'rs-operator)
			(clim:formatting-row 
			 (stream)
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" (first rs)))
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" f1))
			 (clim:formatting-cell 
			  (stream)
			  (format stream "~A" f2)))))))))))



;;; ----------------------------------------------------------------------
;;; Basic realization set editing...
;;;  ... activated when a particular line in the realization statement
;;;  editing table is clicked upon. The object contains the realization
;;;  statement clicked on. The realization set as a whole is the current
;;;  value of the frame slot rs-set.
;;;
;;; 4.0 note that if we expand realization operations that have more
;;;     then the minimal number of operands, then we get a problem
;;;     here because they are not findable anymore on the original
;;;     rs-set!

(clim:define-presentation-action PRESENT-RS-OP
    (rs-operator nil system-editor-frame
                 :documentation "Edit realisation statement")
  (object)
  (with-slots (created-system feature rs-set) clim:*application-frame*
    (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	  (system-outputs (skeleton-system-outputs created-system))
	  (rs object))
      (setf rs-set 
	(mapcar #'(lambda (r)
		    (if (equal r rs)
			(let ((new-rs 
			       (kpml::build-realization-statement-menu 
				feature stream :default rs)))
			  (if new-rs new-rs r))
		      r))
		rs-set))
      (setf (skeleton-system-outputs created-system)
	(loop for o in system-outputs
	    unless (string= (string (second o)) (string feature))
	    collect o
	    else collect `(,(first o) ,(second o) ,@rs-set)))
      (setf (slot-value clim:*application-frame* 'modified) T)
      (check-feature-function-definitions)
      (clim:redisplay-frame-pane clim:*application-frame* 
				 'system-pane :force-p T)
      (clim:redisplay-frame-pane clim:*application-frame* 
				 'rs-set :force-p T))))

(clim:define-presentation-action DELETE-RS-OP
    (rs-operator nil system-editor-frame :gesture :menu
                 :documentation "Delete realization statement")
  (object)
  (with-slots (created-system feature rs-set) clim:*application-frame*
    (let ((system-outputs (skeleton-system-outputs created-system))
	  (rs object))
      (setf *cut-realization-statement* rs)
      (setf rs-set 
	(loop for r in rs-set
	    unless (equal r rs)
	    collect r))
      (setf (skeleton-system-outputs created-system)
	(loop for o in system-outputs
	    unless (string= (string (second o)) (string feature))
	    collect o
	    else collect `(,(first o) ,(second o) ,@rs-set)))
      (check-feature-function-definitions)
      (setf (slot-value clim:*application-frame* 'modified) T)
      (clim:redisplay-frame-pane clim:*application-frame* 
				 'system-pane :force-p T)
      (clim:redisplay-frame-pane clim:*application-frame* 
				 'rs-set :force-p T))))

;;; ----------------------------------------------------------------------
;;; (iii) on features in the entry condition...

;;; Following does not work---changing the order of the inputs
;;; does funny things to the graph...

#+ignore
(clim:define-presentation-action system-popup-ec-action
    (gr-entry-condition nil system-editor-frame
		       :documentation "Move feature in graph")
  (object)
  (with-slots (created-system moved-ec-features)
      clim:*application-frame*
    (pushnew object moved-ec-features)
    (clim:redisplay-frame-pane clim:*application-frame*
			       'system-pane :force-p T)))

;; 2.1
(clim:define-presentation-action system-popup-ec-action
    (gr-entry-condition nil system-editor-frame
		       :documentation "Make NEW system for this feature")
  (object)
  (let ((calling-frame (slot-value clim:*application-frame* 'calling-frame)))
    (create-a-new-system-editing-graph 
     nil object 
     (skeleton-system-region
      (slot-value clim:*application-frame* 'created-system))
     nil calling-frame)))




;;; ----------------------------------------------------------------------
;;; Operations on properties of the system as a whole can be put
;;; under the following menu...
;;;
;;;  patches: 2.0.35, 2.0.51 too
;;; ----------------------------------------------------------------------

(clim:define-presentation-action PRESENT-WORKING-SYSTEM
    (gr-system nil system-editor-frame 
               :documentation "Chooser, example, and region options")
  (object)
  (declare (ignore object))
  (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (with-slots (created-system) clim:*application-frame*
      (case
	  (menu-choose
	   `(("Name/Rename chooser" :value :name-chooser)
	     ("Remove chooser association" :value :remove-chooser)    ;; 2.0.51
	     ("Display chooser" :value :display-chooser)
             ("Make new chooser for this system" :value :new-chooser) ;; 2.1
	     ("Show contrastive examples" :value :display-exs)
	     ("Set region" :value :set-region)))
        (:display-exs
         (bring-up-a-list-of-examples 
	  (mapcar #'second (skeleton-system-outputs created-system))))
        (:remove-chooser                            ;; 2.0.51
         (setf (skeleton-system-chooser created-system) nil)
         (setf (slot-value clim:*application-frame* 'modified) T))
        (:display-chooser
         (kpml::describe-chooser (skeleton-system-chooser created-system)))
        ;; 2.1 start a chooser editor frame or edit window for a new chooser tailored
        ;;     to the current system...
        (:new-chooser
         (let ((new-chooser 
                (kpml::make-new-chooser-with-name-and-outputs
                 (skeleton-system-name created-system)
                 (skeleton-system-outputs created-system))))
           (if (or *kpml-internal-new-object-creation*
                   (eq (cdr (assoc :chooser *kpml-editing-method*)) :kpml))
               (make-a-chooser-editor new-chooser)
             (edit-object new-chooser :chooser))))
        (:name-chooser
         (let ((chooser-name nil))
	   (clim:accepting-values
	       (stream :own-window *own-window*
		       :scroll-bars :horizontal
		       :resynchronize-every-pass t
		       :label "Set chooser name for system"
		       :exit-boxes '((:exit "Click here to accept name")
				     (:abort "Click here to cancel")))
	     (setf chooser-name
	           (intern 
	            (string-upcase
	             (clim:accept 
		      'clim:string :stream stream
		      #+lispworks :view #+lispworks clim:+textual-dialog-view+
		      :prompt "Chooser name"))
	            "KPML"))
	     (kpml-i-terpri stream))
	   (when chooser-name
	     (setf (skeleton-system-chooser created-system) chooser-name)
	     (setf (slot-value clim:*application-frame* 'modified) T))))
        (:set-region
         ;; 2.0.35 was not giving much of an option to select new regions
         (let ((selected-region nil))
	   (if (and (clim:notify-user 
		     clim:*application-frame*
		     "Use an existing region?" 
		     :style :question
		     :exit-boxes '((:exit "Yes")(:abort "No")))
		    (setf selected-region (select-a-region-menu)))
	       (progn
	         (setf (skeleton-system-region created-system) selected-region)
	         ;; 2.0.35
	         (rename-current-window 
		  (system-editing-window-name-from-skeleton created-system))
	         (setf (slot-value clim:*application-frame* 'modified) T))
	     (let ((region-name nil))
	       (clim:accepting-values
		   (stream :own-window *own-window*
			   :scroll-bars :horizontal
			   :resynchronize-every-pass t
			   :label "Set region for system"
			   :exit-boxes '((:exit "Click here to accept region")
				         (:abort "Click here to cancel")))
	         (setf region-name
		       (intern 
		        (string-upcase
		         (clim:accept 
		          'clim:string :stream stream
		          #+lispworks :view #+lispworks clim:+textual-dialog-view+
		          :prompt "Region name"
		          :default (string region-name)))
		        "KPML"))
	         (kpml-i-terpri stream))
	       (when region-name
                 (setf (slot-value clim:*application-frame* 'modified) T)
                 (setf (skeleton-system-region created-system) region-name)
                 ;; 2.0.35 changed region, so change name of window
                 ;;        too!
                 (rename-current-window 
                  (system-editing-window-name-from-skeleton created-system))
                 )))))))))
  

;;; ----------------------------------------------------------------------
;;; 2.0.35 following is the same as system-editing-window-name but
;;;        takes its information from the working system skeleton
;;;        and not the exported loaded system version...
;;; ----------------------------------------------------------------------

(defun SYSTEM-EDITING-WINDOW-NAME-FROM-SKELETON (created-system)
  (concatenate 'string
    "system-editor: "
    (string (skeleton-system-name created-system))
    (if (skeleton-system-region created-system)
	(concatenate 
	    'string " [region: " 
	    (string (skeleton-system-region created-system)) "]")
      "")
    " [" (string kpml::curlan) "]"
    (if (kpml::fetch-system-patch-status 
	 (skeleton-system-name created-system)) "  (***patched***)" ""))
  )

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

(defun EDIT-FEATURE-NAME (object)
  (let ((new-feature object)
	(stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (clim:accepting-values
	(stream :own-window *own-window*
		:scroll-bars :horizontal
		:resynchronize-every-pass t
		:label (concatenate 'string "Edit feature: " (string object))
		#+lispworks :width #+lispworks 300 
		#+lispworks :height #+lispworks 200
		:exit-boxes '((:exit "Accept modified feature name")
			      (:abort "Click here to cancel")))
      (setf new-feature
	(intern 
	 (string-upcase
	  (clim:accept 'clim:string :stream stream
		       #+lispworks :view #+lispworks clim:+textual-dialog-view+
		       :prompt "Feature name"
		       :default (string new-feature)))
	 "KPML"))
      (kpml-i-terpri stream)
      #+lispworks (kpml-i::dialog-end-spacing))
    new-feature))


