(in-package "KPML-I")
;;;
;;; File: graphical-focusing-selection.lisp
;;; 
;;; Adds a newstyle of interaction to the interface. Present
;;; for experimentation. Disabled by default. Set flag to T to use.
;;; Added to KPML 1.0 as patch .18

;;; N.B. not yet ported for Harlequin Lispworks... the frame definitions
;;;      need to be looked at carefully so that Lispworks somewhat
;;;      delicate pane layout algorithm...

;;; ----------------------------------------------------------------------
(defvar *object-focusing-frame* nil
  "holds the object focusing frame")
(defvar *object-focusing-process* nil
  "holds the object focusing process")

(defvar +dark-gray+ nil)

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

(defstruct lfo-node 
  name prop-name children status read-action write-action)

;;; Following structure is used by the graphical focusing frame. It
;;; is kept consonant with the KPML control flags by means of explicit
;;; imports and exports that are done at appropriate places. The initial
;;; value here is also the initial value that would be set by the
;;; first import if no changes have been made by the user prior to
;;; use. The structure also contains the default methods for loading
;;; and saving various groupings of linguistic objects as defined
;;; in kpml-resource-management.lisp. Could do this
;;; all in a more pointedly object-oriented way I suppose but we can
;;; experiment with the following as a first cut to see how the
;;; interface behaves and how folks like it...

(defvar *LINGUISTIC-OBJECTS-HIERARCHY*
    (make-lfo-node
     :name '|Resource set| :status :on 
     :read-action #'kpml::load-linguistic-resources
     :write-action #'kpml::save-linguistic-resources
     :children
     (list
      (make-lfo-node :name '|properties| :prop-name :properties :status :on
		     :read-action #'kpml::load-properties
		     :write-action #'kpml::save-properties)
      (make-lfo-node 
       :name '|grammar| :status :on
       :read-action #'kpml::load-grammar
       :write-action #'kpml::save-grammar
       :children 
       (list 
	(make-lfo-node :name '|systems| :status :on
		       :prop-name :systems
		       :read-action #'kpml::load-systems
		       :write-action #'kpml::save-systems)
	(make-lfo-node :name '|choosers| :status :on
		       :prop-name :choosers
		       :read-action #'kpml::load-choosers
		       :write-action #'kpml::save-choosers)
	(make-lfo-node :name '|inquiries| :status :on
		       :prop-name :inquiries
		       :read-action #'kpml::load-inquiries
		       :write-action #'kpml::save-inquiries)
	(make-lfo-node :name '|punctuation| :status :on
		       :read-action #'kpml::load-punctuation
		       :write-action #'kpml::save-punctuation
		       :prop-name :punctuation)
	(make-lfo-node :name '|ordering constraints| 
		       :read-action #'kpml::load-default-orderings
		       :write-action #'kpml::save-default-orderings
		       :status :on 
		       :prop-name :default-orderings)))
      (make-lfo-node :name '|lexicons| :status :on :prop-name :lexemes
		     :read-action #'kpml::load-lexicons
		     :write-action #'kpml::save-lexicons)
      (make-lfo-node :name '|examples| :status :on :prop-name :examples
		     :read-action #'kpml::load-examples
		     :write-action #'kpml::save-examples)
      (make-lfo-node :name '|patches| :status :off 
		     :prop-name :resource-patches
		     :read-action #'kpml::load-language-patches
		     :write-action #'kpml::save-language-patches)
      (make-lfo-node :name '|inquiry 
      implementations| :status :on :prop-name :inquiry-implementations
      :read-action #'kpml::load-inquiry-implementations)
      (make-lfo-node :name '|inquiry defaults| :status :on 
		     :prop-name :inquiry-defaults
		     :read-action #'kpml::load-spl-defaults-and-macros)
      (make-lfo-node :name '|domains| :status :on :prop-name :domains
		     :read-action #'kpml::load-domains)
      (make-lfo-node :name '|code patches| :status :off
		     :prop-name :kpml-lg-specific-patches
		     :read-action #'kpml::load-kpml-lg-specific-patches)))
  "the hierarchy of KPML linguistic object classes")
 
;;; ----------------------------------------------------------------------
;;; Application frame definition and layout

(clim:define-application-frame focusing-operations-frame ()
  ()
  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (:menu-bar nil)
  (:command-table 
   (focusing-operations-frame
    :inherit-from (clim:user-command-table clim:accept-values-pane)))
  (:panes (objects     :application
		       :incremental-redisplay T
		       :display-function 'object-focus-displayer
		       :foreground resource-graph-fg
		       :scroll-bars nil
		       :background resource-graph-bg
		       :text-style *sans-serif--bold--10*)
	  (regions     :accept-values
		       :scroll-bars nil
		       :display-function 
		       `(clim:accept-values-pane-displayer
			:displayer ,#'region-focus-displayer)
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
	  (languages   :accept-values
		       :display-function 
		       `(clim:accept-values-pane-displayer
			:displayer ,#'language-focus-displayer)
		       :scroll-bars nil
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
	  (menu        :command-menu
		       :foreground menu-fg
		       :background menu-bg
		       :text-style *menu-font*))
  (:layouts 
   (objects-layout 
    (clim:vertically () 
      #-lispworks (40 menu) #+lispworks menu
      (:fill 
       (clim:horizontally ()
	 (:fill 
	  (clim:vertically ()
	    objects
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Object Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-object-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'objects-layout)))))
	 (1/6 
	  (clim:vertically ()
	    regions
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Region Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-region-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'regions-layout)))))
	 (1/6 
	  (clim:vertically ()
	    languages
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Language Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-language-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'languages-layout)))))))))
   
   (regions-layout 
    (clim:vertically () 
      #-lispworks (40 menu) #+lispworks menu
      (:fill
       (clim:horizontally ()
	 (1/6
	  (clim:vertically ()
	    objects
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Object Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-object-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'objects-layout)))))
	 (:fill
	  (clim:vertically ()
	    regions
	    (clim:make-pane 'clim:push-button
			    :background clim:+yellow+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Load Region"
			    :client clim:*application-frame* 
			    :id 'graph-region
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(let ((lgs 
				       (if (second kpml::*languages-in-focus*)
					   kpml::*languages-in-focus*
					 (first kpml::*languages-in-focus*))))
				  (loop for r in kpml::*regions-in-focus*
				      do (kpml::load-region 
					  lgs r
					  :clear kpml::*clearing-flag*)))))
	    (clim:make-pane 'clim:push-button
			    :background clim:+yellow+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Store Region"
			    :client clim:*application-frame* 
			    :id 'graph-region
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(let ((lgs 
				       (if (second kpml::*languages-in-focus*)
					   kpml::*languages-in-focus*
					 (first kpml::*languages-in-focus*))))
				  (loop for r in kpml::*regions-in-focus*
				      do (kpml::save-region 
					  lgs r 
					  :clear kpml::*clearing-flag*)))))
	    (clim:make-pane 'clim:push-button
			    :background clim:+yellow+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Graph Region"
			    :client clim:*application-frame* 
			    :id 'graph-region
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(graph-under-current-options 
				 (first kpml::*regions-in-focus*) 
				 :region-flag T)))
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Region Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-region-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'regions-layout)))))
	 (1/6 
	  (clim:vertically ()
	    languages
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Language Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-language-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'languages-layout)))))))))
   
   (languages-layout 
    (clim:vertically () 
      #-lispworks (40 menu) #+lispworks menu
      (:fill 
       (clim:horizontally ()
	 (1/6
	  (clim:vertically ()
	    objects
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Object Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-object-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'objects-layout)))))
	 (1/6 
	  (clim:vertically ()
	    regions
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Region Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-region-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'regions-layout)))))
	 (:fill 
	  (clim:vertically ()
	    languages
	    (clim:make-pane 'clim:push-button
			    :background clim:+cyan+
			    :foreground clim:+red+
			    :text-style *sans-serif--italic--8*
			    :label "Language Focusing"
			    :client clim:*application-frame* 
			    :id 'raise-language-focusing
			    :activate-callback
			    #'(lambda (gadget)
				(declare (ignore gadget))
				(setf (clim:frame-current-layout 
				       clim:*application-frame*)
				  'languages-layout)))))))))
   
   )
  (:command-definer t))


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

(defmethod OBJECT-FOCUS-DISPLAYER ((frame focusing-operations-frame) stream)
  (clim:updating-output (stream :unique-id *linguistic-objects-hierarchy*)
    (clim:format-graph-from-roots
     (list kpml-i::*linguistic-objects-hierarchy*)
     #'(lambda (node s)
	 (let* ((object-class (lfo-node-name node)))
	   (clim:updating-output 
	       (s :cache-value (lfo-node-status node))
	     (clim:with-output-as-presentation
		 (s node 'focusing-operation-node)
	       (if (eq (lfo-node-status node) :on)
		   (format s "~a" object-class)
		 (clim:with-drawing-options 
		     (s :ink +dark-gray+)
		   (format s "~A" object-class)))))))
     #'lfo-node-children
     :generation-separation 15
     :within-generation-separation 5
     :cutoff-depth nil
     :merge-duplicates nil
     :duplicate-test #'equal
     :move-cursor nil
     :orientation :horizontal
     :stream stream)))

(defmethod LANGUAGE-FOCUS-DISPLAYER ((frame focusing-operations-frame) stream)
  (kpml-i-terpri stream)
  (setf kpml::*languages-in-focus*
	#-(and acl3.0 aclpc)
	(clim:accept `(clim:subset-sequence ,kpml::all_languages)
		     :view #-lispworks 'clim:list-pane-view
		           #+lispworks clim:+textual-dialog-view+
		     :stream stream
		     :prompt "Languages.....
"
		     :default kpml::*languages-in-focus*)
	#+(and acl3.0 aclpc)
	(kpml::get-a-subset-from kpml::all_languages 
				 kpml::*languages-in-focus*
				 "Languages")
	))

(defun REGION-FOCUS-DISPLAYER (frame stream)
  (declare (ignore frame))
  (let ((region-list (kpml::get-regions)))
    (kpml-i-terpri stream)
    (setf kpml::*regions-in-focus*
      #-(and acl3.0 aclpc)
      (clim:accept `(clim:subset-sequence ,region-list)
		   :view #-lispworks 'clim:list-pane-view
		         #+lispworks clim:+textual-dialog-view+
		   :stream stream
		   :prompt "Regions....
"
		   :default kpml::*regions-in-focus*)
      #+(and acl3.0 aclpc)
      (kpml::get-a-subset-from region-list kpml::*regions-in-focus* "Regions")
      )
    ))


;;; ----------------------------------------------------------------------
;;; Presentations and actions...
;;;
;;; Object focusing...

(clim:define-presentation-type focusing-operation-node ())

(clim:define-presentation-action focusing-operation-node-action
  (focusing-operation-node nil focusing-operations-frame)
  (object)
  (progn
    (percolate-status-value 
     object 
     (if (eq (lfo-node-status object) :on) :off :on))
    (export-object-focus-statuses)
    (clim:redisplay-frame-pane clim:*application-frame* 
			       'objects :force-p T)))
  
(defun PERCOLATE-STATUS-VALUE (node status)
  (setf (lfo-node-status node) status)
  (loop for n in (lfo-node-children node)
      when n
      do (percolate-status-value n status)))


(define-focusing-operations-frame-command 
    (com-LFO-BLANK-SPACE-OPTIONS :name t)
    ()
  (case
      (menu-choose
       '(("Object focusing" :value :objects-layout)
	 ("Region focusing" :value :regions-layout)
	 ("Language focusing" :value :languages-layout)))
    (:objects-layout
     (setf (clim:frame-current-layout clim:*application-frame*) 
       'objects-layout))
    (:regions-layout
     (setf (clim:frame-current-layout clim:*application-frame*) 
       'regions-layout))
    (:languages-layout
     (setf (clim:frame-current-layout clim:*application-frame*) 
       'languages-layout))))

(clim:define-presentation-to-command-translator focusing-blank-space-options
    (clim:blank-area com-lfo-blank-space-options focusing-operations-frame
		     :documentation "Focusing operations Bs-options")
  (x y)
  (declare (ignore x y))
  (values))

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

(define-focusing-operations-frame-command 
    (com-CLEAR-OBJECTS :name t :menu t)
    ()
  (remove-object-focusing *linguistic-objects-hierarchy*)
  (export-object-focus-statuses)
  (clim:redisplay-frame-pane clim:*application-frame* 'objects :force-p T))

(defun REMOVE-OBJECT-FOCUSING (node)
  (setf (lfo-node-status node) :off)
  (loop for n in (lfo-node-children node)
      when n
      do (remove-object-focusing n)))

(define-focusing-operations-frame-command 
    (com-CLEAR-REGIONS :name t :menu t)
    ()
  (setf kpml::*regions-in-focus* nil)
  (clim:redisplay-frame-pane clim:*application-frame* 'regions :force-p T))

(define-focusing-operations-frame-command 
    (com-CLEAR-LANGUAGES :name t :menu t)
    ()
  (setf kpml::*languages-in-focus* nil))

(define-focusing-operations-frame-command 
    (com-LOAD-OBJECTS :name t :menu t)
    ()
  (let ((*standard-output* 
	 (clim:get-frame-pane *resource-manager-frame* 'inspector))
	(*error-output*
	 (clim:get-frame-pane *resource-manager-frame* 'inspector)))
    (com-load-linguistic-resource)))

(define-focusing-operations-frame-command 
    (com-STORE-OBJECTS :name t :menu t)
    ()
  (let ((*standard-output* 
	 (clim:get-frame-pane *resource-manager-frame* 'inspector)))
    (com-store-grammar-resource)))

(define-focusing-operations-frame-command 
    (com-QUIT-LFO :name "Quit" :menu t)
    ()
  (close-a-window *object-focusing-frame*)
  (setf *object-focusing-frame* nil
	*object-focusing-process* nil))

;;; ----------------------------------------------------------------------
;;; Startup functions... Resource graphing is triggered from the
;;; resource inspection window.

(defun ASCERTAIN-FOCUSING-OPTIONS-GRAPHICALLY (&optional (reset nil))
  (when reset
    (close-a-window *object-focusing-frame*)
    (setf *object-focusing-frame* nil))
  (unless *object-focusing-frame*
    (import-object-focus-statuses)
    (let ((window-name  "KPML: Linguistic Object Focusing"))
      (setf *object-focusing-frame*
	(clim:make-application-frame
	 'focusing-operations-frame
	 :pretty-name window-name
	 :left 10 :top 10 :width 630 :height 370))
      (setf +dark-gray+
	(cond ((clim:find-named-color 
                "cyan"    ;; changed since gray stolen
                ;; by netscape.
		(cond ((clim:frame-palette *object-focusing-frame*))
                      (t *color-pilot-palette*))
                :errorp nil)
               )
	      (t clim:+yellow+)))
      (setq *object-focusing-process*
	(process-run-function 
	 "KPML-LFO"
	 #'clim:run-frame-top-level *object-focusing-frame*))
      (push (cons *object-focusing-frame*
		  *object-focusing-process*) *frame-process-alist*)
      (values))))

;;; ----------------------------------------------------------------------
;;; Interface back to the rest of KPML and the management flags there...

(defun ENSURE-DEVELOPMENT-ENVIRONMENT-UP ()
  (startup-resource-development-frame)
  (startup-resource-inspector-frame))




(defun EXPORT-OBJECT-FOCUS-STATUSES ()
  (setf kpml::*loading-saving-profile* nil)
  (loop for n in (lfo-node-children *linguistic-objects-hierarchy*)
      do 
	(when (and (lfo-node-prop-name n)(eq (lfo-node-status n) :on))
	  (push (lfo-node-prop-name n) kpml::*loading-saving-profile*))
	(loop for m in (lfo-node-children n)
	    when (and m (lfo-node-prop-name m)(eq (lfo-node-status m) :on))
	    do 	
	      (push (lfo-node-prop-name m) 
		    kpml::*loading-saving-profile*))))

(defun IMPORT-OBJECT-FOCUS-STATUSES ()
  (loop for n in (lfo-node-children *linguistic-objects-hierarchy*)
      do
	(setf (lfo-node-status n) 
	  (if (member (lfo-node-prop-name n) kpml::*loading-saving-profile*)
	      :on
	    :off))
	(loop for m in (lfo-node-children n)
	    when m
	    do 
	      (setf (lfo-node-status m) 
		(if (member (lfo-node-prop-name m) 
			    kpml::*loading-saving-profile*)
		    :on
		  :off)))))


;;; ----------------------------------------------------------------------
;;; Actually, quite a lot of functionality can also be naturally
;;; reached from this view of the linguistic objects maintained.
;;; The following unwieldy function allows the user to reach most
;;; of the KPML functionality directly from the focusing window.
;;; This can be experimented with as an alternative organization for
;;; the interface.

(define-focusing-operations-frame-command 
    (com-LFO-OBJECT-OPTIONS :name t)
  ((object 'focusing-operation-node :gesture :describe)) ;; middle click
  (let ((lgs (if kpml::*languages-in-focus*
		 kpml::*languages-in-focus*
	       (list kpml::curlan)))
	 (*standard-output* 
	  (clim:get-frame-pane *resource-manager-frame* 'inspector))
	 (*error-output*
	  (clim:get-frame-pane *resource-manager-frame* 'inspector)))
    (case
	(menu-choose
	 `(("Load Object" :value :lfo-load-object)
	   ("Store Object" :value :lfo-store-object)
	   ,@(if (string= (lfo-node-name object) "Resource set")
		 '(("Set root resource directory" :value :root)
		   ("Set clearing flag" :value :clearing)
		   ("Set merging flag" :value :merging)))
	   ,@(if (eq (lfo-node-prop-name object) :examples)
		 '(("Generate Example" :value :gen-example)
		   ("Display Example" :value :disp-example)
		   ("Generation Modes" :value :gen-modes)
		   ("Example Runner" :value :example-runner)))
	   ,@(if (string= (lfo-node-name object) "grammar")
		 '(("Reset system network" :value :reset-system-network)
		   ("Consistency checks" :value :checks)))
       ))
      (:root
       (kpml::set-environment-directories))
      (:clearing
       (set-clearing-flag))
      (:merging 
       (set-merging-flag))
      (:reset-system-network
       (ensure-development-environment-up)
       (loop for kpml::curlan in lgs do (kpml::reset-system-network t)))
      (:example-runner
       (kpml::example-runner-to-file-only
		(kpml::list-of-examples) 
		(namestring
		 (merge-pathnames
		  kpml::*example-runner-results*
		  (pathname (kpml::make-example-results-filename))))
		:say-p t))
      (:checks
       (loop for kpml::curlan in lgs 
	   do (kpml::perform-static-consistency-checks
	       :to-file 
	       (concatenate 'string "CONSISTENCY-CHECKS-" 
				    (string kpml::curlan))
	       :lg-restricted t)))
      (:gen-example
       (ensure-development-environment-up)
       (com-generate-sentence))
      (:gen-modes
       (ensure-development-environment-up)
       (run-modes))
      (:disp-example
       (let* ((selected-examples (sort  (example-selector) #'string<))
	      (example-name
	       (possibly-large-example-menu-choose 
		selected-examples 30
		)))
	 (ensure-development-environment-up)
	 (com-display-string-of-example-2 example-name)))
      (:lfo-load-object
       (case (lfo-node-prop-name object) 
	 (:lexemes
	  (kpml::load-individual-lexicons lgs))
	 (:examples
	  (kpml::load-individual-examples lgs))
	 (otherwise
	  (let ((reader (lfo-node-read-action object))
		(l (if (second lgs) lgs (first lgs))))
	    (when reader
	      (if (region-required-p (lfo-node-prop-name object))
		  (loop for r in kpml::*regions-in-focus*
		      do (apply reader    ;; 1.0.32 merges added.
				(list l r :clear kpml::*clearing-flag*
				      :merge kpml::*merging-active*)))
		(apply reader (list l :clear kpml::*clearing-flag*
				    :merge kpml::*merging-active*))))))))
      (:lfo-store-object
       (case (lfo-node-prop-name object)
	 (:lexemes
	  (com-write-lexicon-files))
	 (otherwise
	  (let ((writer (lfo-node-write-action object))
		(l (if (second lgs) lgs (first lgs))))
	    (when writer
	      (if (region-required-p (lfo-node-prop-name object))
		  (loop for r in kpml::*regions-in-focus*
		      do (apply writer (list l r)))
		(apply writer (list l)))))))))))


(defun REGION-REQUIRED-P (object-type)
  (case object-type
    ((:systems :choosers :inquiries)
     T)
    (otherwise
     nil)))

	

(defun SET-MERGING-FLAG ()
  (let ((merging-local (if kpml::*merging-active* :merging :overwriting))
	(stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (clim:accepting-values
     (stream :own-window t
	     :resynchronize-every-pass t
	     :label "Resource merging flag" :exit-boxes 
	     '((:exit "Click here when selection made")
	       (:abort "Click here to cancel")))
     (kpml-i-terpri stream)
     #-lispworks      
     (setf merging-local
	   (clim:accept '(member :overwriting :merging)
			:stream stream
			:view 
			'(clim:list-pane-view :orientation :horizontal)
			:prompt "Merging behaviour....."
			:default merging-local))
     #+lispworks      
     (radio-box-accept merging-local (:overwriting :merging) "Merging behaviour.....")
     (setf kpml::*merging-active*
	   (if (eq merging-local :overwriting)
	       nil T))
     (kpml-i-terpri stream))))

(defun SET-CLEARING-FLAG ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (clim:accepting-values
     (stream :own-window t
	     :resynchronize-every-pass t
	     :label "Resource clearing flag" :exit-boxes 
	     '((:exit "Click here when selection made")
	       (:abort "Click here to cancel")))
      (on-or-off kpml::*clearing-flag* "Clear before monolingual resource loading .")
      (kpml-i-terpri stream))))





