(in-package "KPML-I")
;;;
;;; File: general-facilities.lisp
;;; Author: John Bateman
;;; Created: 14 Oct 95
;;; Last Update: Jan 2000, window things changed for KPML 3.0 and
;;; process handling.
;;;
;;; Functions and functionalities that are general across the window
;;; interface.
;;;
;;; 3.2+    macro added for backward-compatibility of positioned
;;;         accepting-value frames with ACL4.3, 4.3.1
;;;
;;; ----------------------------------------------------------------------
;;;

(defun SET-WINDOW-SIZES (size)
  (if (eq size :big)
      (setf *structure-graph-width* 1100
	    *structure-graph-height* 425
	    *resource-graph-width* 1100
	    *resource-graph-height* 600)
    (setf *structure-graph-width* 440
	  *structure-graph-height* 325
	  *resource-graph-width* 440
	  *resource-graph-height* 325)))

;;; ----------------------------------------------------------------------
;;; Supporting Lisp Version Conditionalization

(defconstant *W-dir* #-acl3.0 "~W" #+acl3.0 "~S")
(defconstant *W-dir-sp* #-acl3.0 "~W " #+acl3.0 "~S ")

#-acl3.0(defun kpml-i-terpri (stream) (terpri stream))

;;; ----------------------------------------------------------------------
;;; Prompter functions...
;;; 2.0 built in a hook for launching tools whenever *starttool* gets
;;;     set to the name of one (a string).
;;;     Such tools are generally only sensible when the development window
;;;     is also loaded, so we separate out tools that are loaded when
;;;     the development frame is active, and others. Others are not
;;;     defined as yet though.

(defun KPML-PROMPT-FUNCTION (stream frame)
  (declare (ignore frame))
  (if kpml::curlan
      (format stream "~A:KPML> " kpml::curlan)
    (format stream "<none>:KPML>"))
  (when kpml::*starttool*
    (let ((tool (assoc kpml::*starttool* *kpml-tool-list* :test #'string=)))
      (when tool
	(setf kpml::*starttool* nil)
	(apply (caaddr tool) (cdaddr tool))))))

(defun KPML-PROMPT-FUNCTION-2 (stream frame)
  (declare (ignore frame))
  (if kpml::curlan
      (format stream "~A:KPML> " kpml::curlan)
    (format stream "<none>:KPML>")))

;;; ----------------------------------------------------------------------
;;; Process starter...

(defun RUN-PACKAGED-FRAME
  (frame *package*)
  (declare (special *package*))
  (setf *package* (find-package "KPML"))
  (clim:run-frame-top-level frame))

;;; ----------------------------------------------------------------------
;;; 0.9: previous close-all-windows replaced by something a little
;;;      more subtle...

(defun CLOSE-ALL-WINDOWS ()
  (setf *resource-manager-frame* nil
	*resource-development-frame* nil
	*resource-inspector-frame* nil
	*generation-history-frame* nil
	*fat-frame* nil)

  (loop for f in *frame-process-alist*
        do (close-a-window (frame-info-name f)))

  (setf *frame-process-alist* nil))

;;; ----------------------------------------------------------------------
;;; 3.0
;;;  Revised and generalized window closing function that keeps track
;;;  of the KPML windows that have been started and attempts to work
;;;  across various Lisp incarnations... This function should be called
;;;  whenever a window is quit in order to register the change in the
;;;  frame overview tool.
;;; ----------------------------------------------------------------------

(defun CLOSE-A-WINDOW (frame-idr)
  (when frame-idr
    (let ((parent nil))
      (check-process-list-integrity)
      #+allegro
      (setf *frame-process-alist*
            (loop for f in *frame-process-alist*
                  if (equalp (frame-info-name f) frame-idr)
                  collect f
                  else
                  do (setf parent (frame-info-parent f))
                  (mp:process-interrupt (frame-info-process-idr f)
                                        #'clim:frame-exit
                                        (frame-info-name f))))
      #+(and acl3.0 aclpc)
      (setf *frame-process-alist*
	    (loop for f in *frame-process-alist*
	          unless (equal (frame-info-name f) frame-idr)
	          collect f
	          when  (equal (frame-info-name f) frame-idr)
	          do (setf parent (frame-info-parent f))
                  (clim:frame-exit (frame-info-name f))))

      #+lispworks
      (progn
        (setf *frame-process-alist*
	      (loop for f in *frame-process-alist*
	            unless (or (equal (frame-info-name f) frame-idr)
                               (equal (mp:process-state (frame-info-process-idr f)) :killed))
	            collect f
	            when  (equal (frame-info-name f) frame-idr)
	            do (setf parent (frame-info-parent f))))
        (raise-orphaned-kpml-frames frame-idr parent)
        (update-frame-list)
        (clim:frame-exit frame-idr))

      (raise-orphaned-kpml-frames frame-idr parent)
      (update-frame-list)
      )))

;;; ----------------------------------------------------------------------
;;; Following make sure that nothing bad ends up on the frame-process-list,
;;; nothing should, but there might be some old bits of code that push
;;; a cons onto the list rather than a frame-info structure. This gets
;;; rid of any such items before they cause any damage, giving a warning
;;; so that the offender can be fixed. If no warnings occur, can drop
;;; this check. Jan 30, 2000.
;;; ----------------------------------------------------------------------

(defun CHECK-PROCESS-LIST-INTEGRITY ()
  (setf *frame-process-alist*
        (loop for f in *frame-process-alist*
              if (frame-info-p f)
              collect f
              else
              do (kpml::warning "Bad item " f " on frame alist. Removed."))))

;;; ----------------------------------------------------------------------
;;; Following function replaces all mention to the frame-idr that
;;; occur as parents on the frame-process alist to the parent of
;;; the frame-idr, so that the dependents do not become orphaned.
;;; Destructively side-effects the frame-process-alist.
;;; ----------------------------------------------------------------------

(defun RAISE-ORPHANED-KPML-FRAMES (frame-idr parent)
  (loop for f in *frame-process-alist*
        when (equal (frame-info-parent f) frame-idr)
        do (setf (frame-info-parent f) parent)))

;;; ----------------------------------------------------------------------
;;; 2.1 Macro borrowed experimentally from SPLAT... 
;;;     looks like one of Markus's to me! Might be of use for collecting
;;;     together some of the horrible conditionalizations that have 
;;;     come into the accepting-values code due to misbehaving Lisp
;;;     alternatives (cf. run-modes below).
;;; ----------------------------------------------------------------------

(defmacro HD-ACCEPTS (var type prompt &optional view)
  `(multiple-value-bind (new-value ignore value-changed)
       (clim:accept ,type :stream stream :default ,var :prompt ,prompt
		    ,@(and view `(:view ,view)))
     (setf ,var new-value)
     value-changed))

;;; ----------------------------------------------------------------------
;;; Small mark making function moved here from example-operations at 2.1...
;;; ----------------------------------------------------------------------

(defun KPML-TICK (stream &key (color clim:+green+))
  (multiple-value-bind (x y)
      (clim:stream-cursor-position stream)
    (clim:with-drawing-options 
	(stream :ink color)
      (clim:draw-circle* stream (+ x 3) (+ y 3) 4))))
  
      


;;; --------------------------------------------------------
;;;			        MODES
;;; --------------------------------------------------------

(defun KPML::RUN-MODES-IN-INTERFACE ()
  (run-modes nil))



;;; need to set the height explicitly or get a bad choice with
;;; ACL-CLIM 2.1.

#-(and acl3.0 aclpc)
(defun RUN-MODES 
  (&optional 
   (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (clim:accepting-values
   (#+acl3.0 *query-io* #-acl3.0 stream :own-window t :resynchronize-every-pass t
           :height #-acl3.0 400 #+acl3.0 250
	   :scroll-bars :vertical
	   :label "Generation Modes" :exit-boxes 
	   '((:exit "Click here to use these values")(:abort "")))
   (setq kpml-i::*example-auto-creation*
     (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view '(clim:radio-box-view :orientation :horizontal)
		      :prompt "Automatically create new examples  ......"
		      :default kpml-i::*example-auto-creation*))
   (clim:with-text-face (#+acl3.0 *query-io* #-acl3.0 stream '(:bold :italic))
     (format #+acl3.0 *query-io* #-acl3.0 stream "~2%          RESULT FOCUSING OPTIONS...~2%"))
   (setf kpml::*cumulate-chooser-activity*
     (clim:accept '(member nil :traced :all) :stream #+acl3.0 *query-io* #-acl3.0 stream
		  #-lispworks :view #-lispworks 'clim:list-pane-view
		  :prompt "Cumulate System and Inquiry Activity  .. "
		  :default  kpml::*cumulate-chooser-activity*))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::store-to-environment-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Update example record fields    ........."
		      :default  kpml::store-to-environment-flag))
   (setf kpml::Domain-Implemented-Value-Compare-Flag
	 kpml::store-to-environment-flag)
   
   (clim:with-text-face (#+acl3.0 *query-io* #-acl3.0 stream '(:bold :italic))
     (format #+acl3.0 *query-io* #-acl3.0 stream "~2%          GENERATION TRACING OPTIONS...~2%"))

   (setq kpml::realize-selectively-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view '(clim:radio-box-view :orientation :horizontal)
		      :prompt "Realize Selectively          ............"
		      :default kpml::realize-selectively-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-constituent-starts
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Constituent Starts          ........"
		      :default  kpml::show-constituent-starts))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setq kpml::*trace-this-constituent*
	 (clim:accept 'clim:integer :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view #-lispworks 'clim:list-pane-view 
                            #+lispworks clim:+textual-dialog-view+
		      :prompt "Realize until constituent number   ......"
		      :default kpml::*trace-this-constituent*))
   (format #+acl3.0 *query-io* #-acl3.0 stream "~%-----")
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::english-trace-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show System and Inquiry Activity   ..... "
		      :default  kpml::english-trace-flag))
   (format #+acl3.0 *query-io* #-acl3.0 stream "~%-----")
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-why-system-is-firing-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Why System is Firing    ............"
		      :default  kpml::show-why-system-is-firing-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::*show-disabled-systems-flag*
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Disabled Candidate Systems  ........"
		      :default  kpml::*show-disabled-systems-flag*))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-dependency-choices
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show System Entry Dependencies   ........"
		      :default  kpml::show-dependency-choices))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-preselections-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Preselections           ............"
		      :default kpml::show-preselections-flag))
   (format #+acl3.0 *query-io* #-acl3.0 stream "~%-----")
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-immediate-realizations-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Immediate Realizations  ............"
		      :default kpml::show-immediate-realizations-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-lexical-features-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Lexical Features        ............"
		      :default  kpml::show-lexical-features-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-lexical-selection
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Lexical Selection       ............"
		      :default  kpml::show-lexical-selection))
   (setf kpml::*show-lexical-selection-flag* kpml::show-lexical-selection)
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   #+ignore   ;; 3.1 ----- the following flag is not used anywhere !!!! -----
   (setf kpml::show-ordering-constraints
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Ordering Constraints    ............"
		      :default  kpml::show-ordering-constraints))
   #+ignore
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::show-ordering-events-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Ordering Events         ............"
		      :default  kpml::show-ordering-events-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::ordering-dump-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Ordering Results        ............"
		      :default  kpml::ordering-dump-flag))
   (format #+acl3.0 *query-io* #-acl3.0 stream "~%-----")
   (kpml-i-terpri stream)
   (setf kpml::display-association-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Associations            ............"
		      :default  kpml::display-association-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setq kpml::*show-inquiry-answer-source*
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Inquiry Answer Source   ............"
		      :default  kpml::*show-inquiry-answer-source*))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setq kpml::show-preselected-response-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Show Entailed Inquiry Response   ........"
		      :default  kpml::show-preselected-response-flag))
   (format #+acl3.0 *query-io* #-acl3.0 stream "~%-----")
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setf kpml::stop-action-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Single Step                  ............"
		      :default  kpml::stop-action-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setq kpml::warning-stop-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Enter Debugger On Warnings   ............"
		      :default kpml::warning-stop-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   (setq kpml::supplement-preselections-flag
	 (clim:accept '(member t nil) :stream #+acl3.0 *query-io* #-acl3.0 stream
		      :view 'clim:radio-box-view
		      :prompt "Interactively augment preselections  ...."
		      :default kpml::supplement-preselections-flag))
   (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
   )
  (when kpml::english-trace-flag
    (startup-generation-history-frame t)
	(startup-fat-frame t))
  (when (or ;; kpml::realize-selectively-flag (this is moved to the display function)
	    kpml::display-association-flag
	    kpml::show-constituent-starts)
	(startup-fat-frame t))
  )


;;; --------------------------------------------------------------------
;;; Support functions for the commands...
;;; 0.9 following *still* wasn't multilingual!
;;;
;;;        Sentence plan to print list was not being sorted.
;;; ----------------------------------------------------------------------

(defun PRINT-SENTENCE-PLAN-FUNCTION ()
  (let ((spl-frame (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	(example-name
	 (possibly-large-example-menu-choose 
	  (sort   ;; 0.9.63
	   (if *example-offers-language-restricted*
	       (kpml::list-of-examples)
	     (mapcar #'car kpml::examples))
	   #'string<)
	  30)))

    (when example-name
      (clim:with-text-style (spl-frame kpml-i::*fix--bold--10*)
	(pen-pprint-for-clim example-name example-name spl-frame)
	(kpml::systemic-display example-name :object-type :example
			  :stream :interface
			  :presentation-handler 
			  #'kpml::kpml-mouse-sensitive-pp)))))




(defun PRINT-EXTENDED-SPL-FUNCTION ()
  (let ((spl-frame (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (when (boundp 'kpml::*plan*)
      (clim:with-text-style (spl-frame kpml-i::*fix--bold--10*)
	(pen-pprint-for-clim 
	 (symbol-value kpml::*plan*) nil spl-frame)))))


;;;----------------------------------------------------------------------
;;;  OUTPUT FUNCTIONS for making sure that things come out
;;;  as presentations of the appropriate types...
;;;----------------------------------------------------------------------

;;; The  following function takes an internal  definition form of some
;;; object (s-exp), the name  of that object (originator), and usually
;;; the stream giving access to   some pane  in the window   interface
;;; (particularly      inspector      in         *inspector*        or
;;; *resource-inspector-frame*).
;;;
;;; kpml-i::pen-pprint-for-clim, depending on the type of the
;;; parameter it receives, calls an appropriate function from 
;;; ml-compatibile-pretty-printing which gives back the definition
;;; of the object as a string. Pen-pprint-for-clim then breaks this
;;; string down into lines, which are processed for mouse
;;; sensitive objects. It has been observed that this displaying 
;;; of objects in the KPML window is very slow. IN CLIM-2 this seems
;;; to be even worse; these functions must be overhauled soon.

;;; Now also contains additional clauses that
;;; (i)  passes strings given
;;;  as arguments directly to the requested stream, but as output
;;;  presentations in an attempt to guarantee that the pane notices
;;; that they are there...
;;; (ii) outputs a list of system names without trying to work out
;;;  that they are indeed system names.
;;; (iii) ditto for lexical items.

(defun PEN-PPRINT-FOR-CLIM 
  (s-exp originator 
	 &optional (output-stream (clim:get-frame-pane 
				   *resource-inspector-frame* 'inspector))
		   (no-newline nil))
  (cond ((eq originator :string)
	 (clim:with-output-as-presentation
	     (output-stream s-exp 'string)
	   (format output-stream "~A " s-exp))
	 (return-from pen-pprint-for-clim nil))
	((eq originator :systems)
	 (loop for sys in s-exp
	       do (clim:with-output-as-presentation
		      (output-stream sys 'system)
		    (format output-stream *W-dir-sp* sys))))
	((eq originator :lexical-items)
	 (loop for lexitem in s-exp
	       do (clim:with-output-as-presentation
		      (output-stream lexitem 'lex-item)
		    (format output-stream *W-dir-sp* lexitem))))
	(t
	 (with-input-from-string
	  (ss  (typecase s-exp         ;; most objects are now handled independently.
		 (kpml::term-graph 
		  (kpml::pretty-format-term-graph nil s-exp))
		 (kpml::example
		  (kpml::pretty-format-spl
		   (kpml::example-logicalform s-exp)))
		 (t
		  (write-to-string s-exp :pretty t))))
	  (unless no-newline (kpml-i-terpri output-stream))
	  (loop for input = (read-line ss nil nil)
		then (read-line ss nil nil)
		while input do
		(progn
		  (typecase s-exp
			    ((or kpml::term-graph kpml::example)
			     (read-and-print-spl-line input 
						      output-stream))
			    (t (if (gethash s-exp kpml::penexamples)
				   (clim:with-output-as-presentation
				       (output-stream s-exp 'example-name)
				     (format output-stream 
					     #-acl3.0 "~%~W"
					     #+acl3.0 "~%~S"
					     s-exp))
				 (read-and-print-pen-line 
				  input output-stream))))
		  (kpml-i-terpri output-stream)
		  ))))))


;;; 1.0.27  small fix...

(defun READ-AND-PRINT-PEN-LINE (string stream)
  (let ((feature-context t))
    (with-input-from-string 
     (line string)
     (loop for char = (read-char line nil nil nil)
	   then  (read-char line nil nil nil)
	   do
	   (progn
	     (if (null char)
		 (return))
	     (if (or (equal char #\( )
		     (equal char #\) )
		     (equal char #\: )
		     (equal char #\, )
		     (equal char #\space))
		 ;;then
		 (clim:with-output-as-presentation
		     (stream char 'character)
		   (princ char stream))
	       ;; else
	       (progn
		 (unread-char char line)
		 (let ((symb (read line nil nil nil)))
		   (cond ((keywordp symb) 
			  (setf feature-context (eq symb :name))
			  symb)
			 ((and (mousable-system? symb)
			       (mousable-feature? symb)) ;; i.e., a gate...
			  (if feature-context
			      (clim:with-output-as-presentation
				  (stream symb 'feature)
				(format stream *W-dir-sp* symb))
			    (clim:with-output-as-presentation
				(stream symb 'system)
			      (format stream *W-dir-sp* symb)))) 
			 ((mousable-system? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'system)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-feature? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'feature)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-inquiry? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'inquiry)
			    (format stream *W-dir-sp* symb)))
			 ;; 0.9.34 added...
			 ((mousable-inquiry-implementation? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'inquiry-implementation)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-chooser? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'chooser)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-spl-term? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'spl-term)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-lex-item? symb)
			  (clim:with-output-as-presentation
			      (stream symb 'lex-item)
			    (format stream *W-dir-sp* symb)))
			 ((mousable-relation?  symb)
			  (clim:with-output-as-presentation
			      (stream symb 'kr-relation)
			    (format stream *W-dir-sp* symb)))
			 ;; Check for relations before concept
			 ;; (because of reified rels)
			 ((mousable-concept?  symb)
			  (clim:with-output-as-presentation
			      (stream symb 'kr-concept)
			    (format stream *W-dir-sp* symb)))
			 ;; unknown type, just print it
			 ;; 1.0.27 but with a sensible presentation type,
			 ;;       otherwise CLIM documentation line can bomb.
			 (t (clim:with-output-as-presentation
				(stream symb
					(typecase symb
					  (string 'string)
					  (number 'number)
					  (symbol 'symbol)
					  (t 'string)))
			      (format stream "~s " symb))
			    ))))))))))

;;; 1.0.27... 

;;; same for this one...

(defun READ-AND-PRINT-SPL-LINE (string stream)
  (with-input-from-string (line string)
    (loop for char = (read-char line nil nil nil)
	  then  (read-char line nil nil nil)
	  do
	  (progn
	    (if (null char)
		(return))
	    (if (or (equal char #\( )
		    (equal char #\) )
		    (equal char #\: )
		    (equal char #\, )
		    (equal char #\space))
		;;then
		(princ char stream)
		;; else
		(progn
		  (unread-char char line)
		  (let ((symb (read line nil nil nil)))
		    (cond ((keywordp symb) symb)
			  ((mousable-inquiry? symb)
			   (clim:with-output-as-presentation
			       (stream symb 'inquiry)
			     (format stream "~a " symb)))
			  ((mousable-spl-term? symb)
			   (clim:with-output-as-presentation
			       (stream symb 'spl-term)
			     (format stream "~a " symb)))
			  ((mousable-relation?  symb)
			   (clim:with-output-as-presentation
			       (stream symb 'kr-relation)
			     (format stream "~a " symb)))
			  ;; Check for relations before concept
			  ;; (because of reified rels)
			  ((mousable-concept?  symb)
			   (clim:with-output-as-presentation
			       (stream symb 'kr-concept)
			     (format stream "~a " symb)))
			  ((mousable-lex-item? symb)
			   (clim:with-output-as-presentation
			       (stream symb 'lex-item)
			     (format stream "~a " symb)))
			  ;; unknown type, just print it
			 ;; 1.0.27 but with a sensible presentation type,
			 ;;       otherwise CLIM documentation line can bomb.
			 (t (clim:with-output-as-presentation
				(stream symb
					(typecase symb
					  (string 'string)
					  (number 'number)
					  (symbol 'symbol)
					  (t 'string)))
			      (format stream "~s " symb))
			   )))))))))

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

(defun mousable-system? (symb)
  (when (symbolp symb)
    (gethash (intern (symbol-name symb) 'penman) kpml::system-table)))

(defun mousable-feature? (symb)
  (when (symbolp symb)
    (gethash (intern (symbol-name symb) 'penman) kpml::all-output-features)))

(defun mousable-inquiry? (symb)
  (when (symbolp symb)
    (gethash (intern (symbol-name symb) 'penman) kpml::quiry-operators)))

(defun mousable-chooser? (symb)
  (when (symbolp symb)
    (gethash (intern (symbol-name symb) 'penman) kpml::choosers)))

(defun mousable-spl-term? (symb)
  (when (symbolp symb)
    (or (member (intern (symbol-name symb) 'penman) kpml::*plan-graphs*)
	(and (boundp (intern (symbol-name symb) 'penman))
	     (typep (symbol-value (intern (symbol-name symb) 'penman))
	       'kpml::term-graph)))))

(defun mousable-lex-item? (symb)
  (when (symbolp symb)
    (gethash (intern (symbol-name symb) 'penman) kpml::lexicon)))

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

(defun PPRINT-FOR-CLIM (s-exp &optional (output-stream t))
  (with-input-from-string (ss (write-to-string s-exp :pretty t))
    (loop for input = (read-line ss nil nil)
	  then (read-line ss nil nil)
	  while input do
	  (progn
	    (kpml-i-terpri output-stream)
	    (read-and-print-line input output-stream)))))


(defun READ-AND-PRINT-LINE (string stream)
  (with-input-from-string (line string)
    (loop for char = (read-char line nil nil nil)
	  then  (read-char line nil nil nil)
	  do
	  (progn
	    (if (null char)
		(return))
	    (if (or (equal char #\( )
		    (equal char #\) )
		    (equal char #\: )
		    (equal char #\space))
		;;then
		(princ char stream)
		;; else
		(progn
		  (unread-char char line)
		  (let ((symb (read line nil nil nil)))
		    (cond ((mousable-relation?  symb)
			   (clim:with-output-as-presentation
			       (stream symb 'kr-relation)
			     (format stream "~a " symb)))
			  ;; Check for relations before concept
			  ;; (because of reified rels)
			  ((mousable-concept?  symb)
			   (clim:with-output-as-presentation
			       (stream symb 'kr-concept)
			     (format stream "~a " symb)))
			  ;; unknown type, just print it
			  (t (format stream "~a " symb))))))))))


;;; ----------------------------------------------------------------------
;;; 1.1 made independent of Loom.

(defun DESCRIBE-KR-CONCEPT-OR-RELATION (object-name kr-type)
  (let* ((object (kpml::kb-getnamedconcept object-name))
	 (stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (cond ((null object)
	   (format stream "~2%;;; ~a not found: ~a" kr-type object-name))
	  (t
	   (let ((defs  (kpml::kb-generate-source-definition object))
		 (annotations (gethash 
			       (kpml::kb-getconceptname object)
			       kpml::*concept-annotations*)))
	     ;(clim:window-clear stream)
	     (kpml-i-terpri stream)
	     (cond ((and (= (length defs) 2)
			 (listp (first defs)))
		    (dolist (def defs)
		      (kpml-i-terpri stream)
		      (pprint-for-clim def stream)
		      (kpml-i-terpri stream)))
		   (t
		    (pprint-for-clim defs stream)))
	     (when annotations
		   (format stream "~% ...with annotations:")
		   (format stream "~%    documentation:")
		   (pprint-for-clim (kpml::kb-concept-doc-strings annotations) stream)
		   (format stream "~%    lexical features:")
		   (pprint-for-clim (kpml::kb-concept-lex-features annotations) stream)
		   (format stream "~%    lexical items:")
		   (pen-pprint-for-clim 
		    (mapcar #'(lambda (x) (intern (string x) "KPML"))
			    (kpml::kb-concept-lex-items annotations))
		    :lexical-items 
		    stream)))))))



#+loom
(defun DESCRIBE-KR-INSTANCE (instance)
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    ;(clim:window-clear stream)
    (kpml-i-terpri stream)
    (format stream "~S" (eval `(loom::pi ,instance)))
    ))

#-loom(defun DESCRIBE-KR-INSTANCE (instance) nil)

(defun MOUSABLE-CONCEPT? (symb)
  (if (and (stringp symb)(string= symb ""))
      nil
    (if #+loom(loom::find-concept symb :no-warning-p t :ignore-package-p t)
        #-loom(kpml::kb-getnamedconcept symb)
	symb)))

(defun MOUSABLE-RELATION? (symb)
  (if (and (stringp symb)(string= symb ""))
      nil
    (if #+loom(loom::find-relation symb :no-warning-p t :ignore-package-p t)
        #-loom(kpml::kb-getnamedconcept symb)
	symb)))


;;; 1.0
;;; add inquiry implementations to the mouseable objects...

(defun MOUSABLE-INQUIRY-IMPLEMENTATION? (symb)
  (when (symbolp symb)
    (kpml::inquiry-implementation-p symb)))

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

(defun EVAL-LISP-EXPRESSION (expr)
  (let ((stream (clim:get-frame-pane clim:*application-frame* 'inspector)))
    (kpml-i-terpri stream)
    (format stream "~%----------------------------------------------")
    (if kpml::*standalone*
	(format stream "~% Not available in standalone mode.")
      (format stream "~%~a ==> ~a" expr (kpml::kpml-eval expr)))
    (format stream "~%----------------------------------------------")
    ))


;;; ----------------------------------------------------------------------
;;; Window renaming... useful when the window name contains useful info,
;;;  such as the system being edited, etc.
;;; ----------------------------------------------------------------------

(defun RENAME-CURRENT-WINDOW (string)
  #+lispworks 
  (common-lisp-user::set-active-window-text string)
  ;; 2.0.36
  #+allegro(:version-case 
	    (":ALLEGRO-V")
	    ((+ "4.2")
	     (setf (clim:frame-pretty-name clim:*application-frame*) string)))
  nil)

;;; ----------------------------------------------------------------------
;;; 3.0
;;; some extras for displaying use of microfunctions...
;;; ----------------------------------------------------------------------

(defun WHO-CAN-AFFECT-MICROFUNCTION (mf+region &optional (stream *standard-output*))
  (let ((m (car mf+region))
        (region (cdr mf+region)))
  (format stream 
          "~2%Usage report for grammatical microfunction: ~@(~A~)" m)
  (loop for (name report-element)
        in `(("Insertions" ,(kpml::kpml-who-can-insert m))
             ("Expansions" ,(kpml::kpml-who-can-expand m))
             ("Conflations" ,(kpml::kpml-who-can-conflate m))
             ("Preselections" ,(kpml::kpml-who-can-preselect m))
             ("Orderings" ,(kpml::kpml-who-can-order m))
             ("Lexifies" ,(kpml::kpml-who-can-lexify m))
             ("Classifications" ,(kpml::kpml-who-can-out-classify m))
             ("Inflections" ,(kpml::kpml-who-can-inflectify m)))
        when report-element
        do
        (format stream "~%~A" name)
        (pprint-function-with-realization region report-element stream))))


(defun PPRINT-FUNCTION-WITH-REALIZATION (region uses stream )
  (let ((*standard-output* stream))
    (loop for (system . realization) in uses
          do 
          (format stream "~%~4T ")
          (clim:with-output-as-presentation (stream system 'system)
            (format stream "~S" system))
          (let ((s-region (kpml::fetch-system-region system)))
            (unless (equal s-region region)
              (format stream " (in: ")
              (clim:with-output-as-presentation (stream s-region 'region)
                (format stream "~S" s-region))
              (format stream ")")))
          (format stream " : ")
          (loop for (f .  r) in realization
                do 
                (format stream "~%~8T")
                (clim:with-output-as-presentation (stream f 'feature)
                  (format stream "~:(~A~)" f))
                (format stream  " [")
                (loop for rs in r do (format stream " ")
                                     (kpml::nonansi-pprint-single-rs rs))
                (format stream "]")
                )
          )))

 ;; ----------------------------------------------------------------------
 ;; 3.2+
 ;;
 ;; The problem requiring the following is that at least Allegro ACL4.3 
 ;; gives a nasty break if we try and say where the accepting values
 ;; windows are to be positioned. So we conditionalize the setting
 ;; of position here and use this macro wherever we might want to
 ;; do a positioned accepting values. This is then a simple fix in
 ;; that we just do a global replace of clim:accepting-values by 
 ;; positioned-accepting-values. This does require recompilation
 ;; however and so cannot be a simple patch.
 ;; ----------------------------------------------------------------------

(defmacro POSITIONED-ACCEPTING-VALUES 
  ((stream &key 
	  (own-window kpml-i::*own-window*)
	  x-position y-position 
	  (scroll-bars nil)
	  (resynchronize-every-pass t)
	  label exit-boxes)
   &body body)
  (let* ((args `(:x-position ,x-position :y-position ,y-position))
	 (position-args
	  #+lispworks     args
	  #+allegro 
	   (:version-case (":ALLEGRO-V")
			  ((- "5.0") nil)
			  (t         args))
	  #-(or lispworks allegro)
	  nil))
    `(clim:accepting-values
      (,stream :own-window ,own-window
	       ,@position-args
	       :scroll-bars ,scroll-bars
	       :resynchronize-every-pass ,resynchronize-every-pass
	       :label ,label
	       :exit-boxes ,exit-boxes)
      ,@body)))