(in-package "KPML-I")
;;;
;;; File: general-facilities.lisp
;;; Author: John Bateman
;;; Created: 14 Oct 95
;;; Last Update:
;;;  May 2002, a fallback notify-user for ACL5.
;;;  Jan 2000, window things changed for KPML 3.0 and
;;;            process handling.
;;;
;;; Functions and functionalities that are general across the window
;;; interface.
;;;
;;; 4.1     LW5 problem with radio-check-boxes under Windows workaround
;;; 4.0     notify-user
;;; 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))

;;; ----------------------------------------------------------------------
;;; 4.0

  ;; ----------------------------------------------------------------------
  ;; 4.0
  ;;   For some strange unknown reason, the clim:notify-user with ACL5 bombs with
  ;;   some stream values that Lispworks is perfectly happy with. Provide
  ;;   an modelled notify user that appears safe...
  ;; ----------------------------------------------------------------------

(defun OWN-NOTIFY-USER (stream string)
  #+lispworks                      (clim:notify-user stream string)
  #-(and :allegro microsoft)       (clim:notify-user stream string)
  #+(and :allegro :microsoft)
 (let ((stream 
	 (clim::frame-top-level-sheet clim:*application-frame*))
        )
      (kpml-i::positioned-accepting-values
	(stream :own-window kpml-i::*own-window*
		:width 400
                :x-position 20 ;;; (first kpml-i::*confirmation-popups-xy*)
                :y-position 20 ;;; (second kpml-i::*confirmation-popups-xy*)
		:scroll-bars :vertical
		:label "Message" 
                :exit-boxes '((:exit "OK")(:abort "Also OK")))
        (format stream "~A" string))))

;;; ----------------------------------------------------------------------
;;; 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.
;;; 4.0
;;;  The conditionalizations for ACL5+ were not correct.
;;; ----------------------------------------------------------------------

(defun CLOSE-A-WINDOW (frame-idr)
  (when frame-idr
    (let ((parent nil))
      (check-process-list-integrity)
      #+(and allegro (not acl3.0))
      (:version-case 
       (":ALLEGRO-V")
       ((- "5.0")
	;; Unclear to me whether this code should work or not with ACL 4.3,
	;; or even where it came from; it certainly does the opposite of
	;; what is required with ACL 5. So see the correction there for
	;; an alternative...
	(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)))))
       ((+ "4.4")
	;; KPML 4.0 alternative for ACL5 and above...
	;;          the old version may just have been untested and old...
	(setf *frame-process-alist*
	  (loop for f in *frame-process-alist*
	      unless (equalp (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-idr)))))

      #+(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))

  ;;------------------------------------------------------------
  ;; 4.1 need the following as radio-box-views are badly behaved in
  ;;       Lispworks 5 under at least Windows XP. So the conditionalisations
  ;;       that are necessary would be repeated in many many places...
  ;;
(defmacro RADIO-BOX-ACCEPT (var options prompt &optional (orientation nil))
  #-(or lispworks4 lispworks5)
  `(progn
     (kpml-i-terpri stream)
     (setf ,var 
           (clim:accept ,(if (symbolp options)
                              `(cons 'clim:member ,options)
                            `(quote ,`(clim:member ,@options)))
			:stream stream
			:view  '(clim:list-pane-view)
			:prompt ,prompt
			:default ,var)))
  #+lispworks4 
  `(progn
     (kpml-i-terpri stream)
     (setf ,var 
           (clim:accept ,(if (symbolp options)
                              `(cons 'clim:member ,options)
                            `(quote ,`(clim:member ,@options)))
                        :stream stream
                        :prompt ,prompt
                        :default var)))
  #+lispworks5
  (if orientation 
      `(progn
         (kpml-i-terpri stream)
         (setf ,var 
               (first
                (clim:accept ,(if (symbolp options)
                                  `(cons 'clim:subset ,options)
                                `(quote ,`(clim:subset ,@options)))
                             :view '(clim:list-pane-view)
                             :stream stream
                             :prompt ,(kpml::string-append prompt " (PICK ONE!)")
                             :default (cons ,var nil)))))

    `(progn
       (kpml-i-terpri stream)
       (setf ,var 
             (first
              (clim:accept ,(if (symbolp options)
                                `(cons 'clim:subset ,options)
                              `(quote ,`(clim:subset ,@options)))
                           :stream stream
                           :prompt ,(kpml::string-append prompt " (PICK ONE!)")
                           :default (cons ,var nil)))))
    ))


  ;; ------------------------------------------------------------
  ;; 4.0 a simpler addition for making the yes/no, on/off queries
  ;;     less Lisp-like (for Stefan Müller)
  ;;
  ;;     N.B. the variable that is set has to have been bound
  ;;          at compile time else you'll get a complaint first
  ;;          time through!
  ;;
  ;;     An example of use (default is to map T->yes and NIL->no):      
  ;;     (replaces the entire setq/setf in the accepting-values body)
  ;;
  ;;       (kpml-i::on-or-off 
  ;;           *resource-directory-versioning*
  ;;           "Create new resource directory  ......")
  ;;
  ;; 4.1 radio-box hack incorporated.
  ;; ------------------------------------------------------------

(defmacro ON-OR-OFF (var prompt &optional (on-off-value :yes-no))
  (cond ((eq on-off-value :yes-no)
         (setf on-value :yes off-value :no))
        (t
         (setf on-value :on off-value :off)))
  #-(or lispworks4 lispworks5)
  `(progn
     (kpml-i-terpri stream)
     (setf ,var
	 (let ((value 
		(clim:accept 
		 '(member ,on-value ,off-value) 
		 :stream stream
		 :prompt ,prompt
		 :default (if ,var ,on-value ,off-value))))
	   (if (equal value ,on-value)
	       T
	     nil))))
  #+lispworks4 
  `(progn
     (kpml-i-terpri stream)
     (setf ,var
	 (let ((value 
		(clim:accept 
		 '(member ,on-value ,off-value) 
		 :stream stream
		 :view 'clim:radio-box-view
		 :prompt ,prompt
		 :default (if ,var ,on-value ,off-value))))
	   (if (equal value ,on-value)
	       T
	     nil))))
  #+lispworks5
  `(progn
     (kpml-i-terpri stream)
     (setf ,var
	 (let ((value 
		(first 
		 (clim:accept 
		  '(clim:subset ,on-value ,off-value) 
		  :stream stream
		  :prompt ,prompt
		  :default (cons (if ,var ,on-value ,off-value) nil)))))
	   (if (equal value ,on-value)
	       T
	     nil))))
  )


;;; ----------------------------------------------------------------------
;;; 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. 
;;; 4.1 
;;;   For LW5 updated to use the radio-box macro/workaround...
;;;   Update follows this below...

#-(or (and acl3.0 aclpc) lispworks5)
(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))
  )


;;; ACL3 on PCs no longer supported... 
#+(and acl3.0 aclpc)
(defun RUN-MODES 
  (&optional 
   (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (format t "~%ACL3.0/PC no longer supported."))


#+lispworks5
(defun RUN-MODES 
  (&optional 
   (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (unless stream (setf stream 
                       (clim::frame-top-level-sheet clim:*application-frame*)))
  (clim:accepting-values
   (stream :own-window t :resynchronize-every-pass t
           :height 400 
	   :scroll-bars :vertical
	   :label "Generation Modes" :exit-boxes 
	   '((:exit "Click here to use these values")(:abort "")))
    (on-or-off kpml-i::*example-auto-creation* "Automatically create new examples  ......")
    (clim:with-text-face (stream '(:bold :italic))
      (format stream "~2%          RESULT FOCUSING OPTIONS..."))
    (radio-box-accept kpml::*cumulate-chooser-activity* (:traced :all) "Cumulate System and Inquiry Activity  .. ")
    (on-or-off kpml::store-to-environment-flag "Update example record fields    .........")
    (setf kpml::Domain-Implemented-Value-Compare-Flag kpml::store-to-environment-flag)
    (clim:with-text-face (stream '(:bold :italic))
      (format stream "~2%          GENERATION TRACING OPTIONS..."))
    (on-or-off kpml::realize-selectively-flag "Realize Selectively          ............")
    (on-or-off kpml::show-constituent-starts "Show Constituent Starts          ........")
    (kpml-i-terpri stream)
    (setq kpml::*trace-this-constituent*
          (clim:accept 'clim:integer :stream stream
                       :view #-lispworks 'clim:list-pane-view 
                       #+lispworks clim:+textual-dialog-view+
                       :prompt "Realize until constituent number   ......"
                       :default kpml::*trace-this-constituent*))
    (format stream "~%-----")
    (on-or-off kpml::english-trace-flag "Show System and Inquiry Activity   ..... ")
    (on-or-off kpml::show-why-system-is-firing-flag "Show Why System is Firing    ............")
    (on-or-off kpml::*show-disabled-systems-flag*  "Show Disabled Candidate Systems  ........")
    (on-or-off kpml::show-dependency-choices "Show System Entry Dependencies   ........")
    (on-or-off kpml::show-preselections-flag  "Show Preselections           ............")
    (on-or-off kpml::show-immediate-realizations-flag  "Show Immediate Realizations  ............")
    (on-or-off kpml::show-lexical-features-flag  "Show Lexical Features        ............")
    (on-or-off kpml::show-lexical-selection "Show Lexical Selection       ............")
    (setf kpml::*show-lexical-selection-flag* kpml::show-lexical-selection)
    (on-or-off kpml::show-ordering-events-flag "Show Ordering Events         ............")
    (on-or-off kpml::ordering-dump-flag "Show Ordering Results        ............")
    (on-or-off kpml::display-association-flag "Show Associations            ............")
    (on-or-off kpml::*show-inquiry-answer-source* "Show Inquiry Answer Source   ............")
    (on-or-off kpml::show-preselected-response-flag "Show Entailed Inquiry Response   ........")
    (format stream "~%-----")
    (on-or-off kpml::stop-action-flag "Single Step                  ............")
    (on-or-off kpml::warning-stop-flag "Enter Debugger On Warnings   ............")
    (on-or-off kpml::supplement-preselections-flag "Interactively augment preselections  ....")
    (kpml-i-terpri 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.
;;; 4.0 add a little extra for displaying the information as a 
;;;     pop-up notification window instead. Single describe
;;;     function make conditional on a switch and broken
;;;     into a stream dependent function.

(defun DESCRIBE-KR-CONCEPT-OR-RELATION (object-name kr-type)
  (if *concept-info-as-popups?*
      (let ((info (with-output-to-string 
		    (stream)
		    (describe-kr-concept-or-relation-on-stream 
		     object-name kr-type stream))))
	(clim:notify-user clim:*application-frame* info))
    (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
      (describe-kr-concept-or-relation-on-stream object-name kr-type stream))
    ))
       

(defun DESCRIBE-KR-CONCEPT-OR-RELATION-ON-STREAM (object-name kr-type stream)
  (let* ((object (if (symbolp object-name)
		     (kpml::kb-getnamedconcept object-name)
		   object-name)))
    (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 "~2% ...with annotations:")
		   (format stream "~2%    documentation:")
		   (pprint-for-clim 
		    (kpml::kb-concept-doc-strings annotations) stream)
		   (format stream "~2%    lexical features:")
		   (pprint-for-clim 
		    (kpml::kb-concept-lex-features annotations) stream)
		   (format stream "~2%    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)
          (width 400)                       ;; 4.0: noticed by ACL5
	  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
	       :width ,width
	       :resynchronize-every-pass ,resynchronize-every-pass
	       :label ,label
	       :exit-boxes ,exit-boxes)
      ,@body)))


  ;; ----------------------------------------------------------------------
  ;; 3.2.19 add proper HTML header material (also in example-mismatches.lisp)
  ;; 3.2.46 sorting examples when marked only added and also made to
  ;;        produce reports even when in demo mode.
  ;; 3.2.60 additions for Unicode webpages...
  ;; 4.0    further Unicode compatibility...
  ;; ----------------------------------------------------------------------

(defun GET-CHARSET (&optional (language kpml::curlan))
  (case language
	(:english "iso-8859-1")
	(otherwise
	 ;; 3.2.60+4.0
	 (if (or (equal (kpml::code-page-for-lg language :force-p T) :unicode)
		 *unicode-in-reports*)
	     "UTF-8"
	   (format nil "windows-~A" 
		   (kpml::code-page-for-lg language :force-p T))))))

(defmacro AS-HTML ((title) &body body)
  `(progn
     (format stream "~%<html><head>")
     (format stream
	     "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=~A\">" (get-charset))
     (format stream "~%<title>~A</title>" ,title)
     (format stream "~%</head>")
     ,@body
     (format stream "~%</body></html>")))

  ;; ----------------------------------------------------------------------
  ;; 3.2.39
  ;; ----------------------------------------------------------------------

(defun CHOOSE-FROM-LIST (list &key (name "Choose") (func 'car))
  (kpml-i::menu-choose 
   list
   :associated-window 
   (clim:frame-top-level-sheet clim:*application-frame*)
   :label name))

  ;; ----------------------------------------------------------------------
  ;; 3.2.41
  ;;
  ;; The following is defined because it looks as if Lispworks 4.1 can 
  ;; now handle the clim's filling output, whereas 4.0 tended to be
  ;; unhappy. The macro is version dependent so that it only uses the
  ;; the filling-output environment when either Lispworks 4.1 or later
  ;; is being used or some other Lisp. This latter will need to be checked
  ;; for ACL5 etc.
  ;; ----------------------------------------------------------------------

(defmacro FILLING ((rightdent) &body body)
  #+lispworks 
  (:version-case 
   (":LISPWORKS")
   ((+ "4.0") 
    `(clim:filling-output 
      (stream :fill-width 
	      (- (clim:bounding-rectangle-width 
		  (clim:window-viewport stream))
		 ,rightdent))
      ,@body))
   (t
    `(progn ,@body)))
  #-lispworks
  `(clim:filling-output 
      (stream :fill-width 
	      (- (clim:bounding-rectangle-width 
		  (clim:window-viewport stream))
		 ,rightdent))
      ,@body))


  ;; ----------------------------------------------------------------------
  ;; 4.0 Some webservers may have their security settings such that
  ;;     directories with the extension .dir (as used to be the case
  ;;     for KPML example reports in version 3) do not get served,
  ;;     which is a pain. Especially since this behavior can be changed
  ;;     at the whim of the server manager. So we head this off
  ;;     here and do not use .dir as an extension, adding it instead
  ;;     into the file name and not giving an extension. The old 
  ;;     behaviour can be obtained by a fourth optional argument
  ;;     called :force-p
  ;; ----------------------------------------------------------------------

(defun MAKE-NEW-TYPED-FILENAME 
  (type lg 
	&optional (filetype "lisp")(forcep nil))
  (multiple-value-bind 
   (second minute hour date month year) 
      (get-decoded-time)
    (declare (ignore second minute hour))
    (if (or forcep 
	    (not (string= filetype "dir")))
	(format nil "~a-~a-~a~2,'0D~2,'0D.~A" 
		(string lg) type year month date filetype)
      (format nil "~a-~a-~a~2,'0D~2,'0D-dir" 
	      (string lg) type year month date))))


;;; ----------------------------------------------------------------------
;;; 4.0 macro for putting the telltale character at the front of Unicode
;;;     files so that browsers, etc. recognise them as such... 
;;; ----------------------------------------------------------------------

(defmacro UNICODE-STAMP ()
  #+lispworks'(when *unicode-in-reports* 
		;;           (int-char 65279) 
		(write-char  #\Zero-Width-No-Break-Space stream))
  #-lispworks ()
  )

;;; ----------------------------------------------------------------------
;;; 4.0 some of the bugs/problems with ACL5/6 and KPML can most easily
;;;     be solved by telling the user to DO THE RIGHT THING! 
;;; ----------------------------------------------------------------------

(defvar *allegro-mod-v5*
    "With Allegro ACL 5 and later there are still
some interactions between the window system, character code handling,
and multitasking that are not very compatible with the pre-ACL 5/6
structures found in KPML. To avoid problems, always generate your
first sentence using the EXAMPLE MANAGER! This message will
disappear should the problem finally be solved.")

(defun MESSAGE-OF-THE-DAY ()
  #+allegro
  (:version-case (":ALLEGRO-V")
		 ((+ "4.4") 
		  (clim:notify-user clim:*application-frame*
				    *allegro-mod-v5*))))
	    
