(in-package "KPML-I")
;;;
;;; File: example-operations.lisp
;;; Author: John Bateman
;;; Created: 4 Jan 97, Cambridge.
;;;
;;; KPML 1.1 redoes the primitive example operations menu and list of
;;; examples given for a request to generate by providing a more comprehensive
;;; management facility for handling sets of examples.
;;;
;;; The commands from the example manager replace all of the options
;;; previously available under the Example Operations menu command.
;;; These are: loading and writing individual example sets, clearing
;;; the examples, graphing, showing the string and generating specified
;;; examples, deleting and renaming examples, getting feature use 
;;; surveys, and running the example runner.
;;;
;;; 2.1 added regression support of sorts, 30 June 99, Bremen.
;;;     most presentation actions moved to the :menu gesture.
;;; 4.1 more regression support, December 2007, Bremen.
;;; ----------------------------------------------------------------------

;;; Globals...

(defvar *ex-op-frame* nil)
(defvar *list-examples-alphabetically* T)
(defvar *list-marked-examples-first* nil)   ;; 4.1
(defvar *texty-index-mode* nil)
(defvar *example-filter-method* :selected)
(defvar *example-set-restriction* nil)
(defvar *example-menu-width* 35    "width of string used in example menus")
(defvar *example-display-options* '(:target :generated :none)
  "options for displaying strings associated with examples")
(defvar *example-differences-mode* nil 
  "general activation of checking generated/target string mismatches") 

(defvar *focused-exercise-set* nil "currently focused named exercise set")

(defvar *currently-marked* nil)
(defvar *currently-focused-examples* nil)

(defvar *example-manager-deleted* nil)

;;; Following can be set from the generated example string frame...
;;; (defined in misc-extra-frames)
(defvar *max-examples-shown* 4)
(defvar *max-neg-examples-shown* 2)
(defvar *sort-examples-by-length* T)

(defvar *exrun-complexity-maximum* nil)

  ;; 4.0    Unicode for reports forced, regardless of whether this is
  ;;        specified in the font property declaration. When set, the
  ;;        declaration for a given language is temporarily overridden
  ;;        and this could conceivably have side-effects elsewhere...
(defvar *unicode-in-reports* nil)

;;; ----------------------------------------------------------------------
;;; Submenus for the menu bar...

(clim:define-command-table 
 EXOP-FILE-MENU-COMMAND-TABLE
    ;; 2.0.55 
    :menu (("Load an Example Set" :command com-load-example-files-em)
           ("Load all Example Sets for current language" :command com-load-example-sets)
	   ("Reload Last File" :command com-reload-last-example-file)
           ("Divider3" :divider nil)
	   ("Save Example Sets" :command com-write-example-files-em)
	   ("Save an Example Set" :command com-write-example-set)
	   ("Save Marked Examples" :command com-save-marked-examples)
	   ("Divider1" :divider nil)
	   ("Toggle full example structure saving" 
	    :command com-exop-full-structure)
           ("Divider2" :divider nil)
	   ("Environment Directories" :command com-environment-directories-em)
	   #-acl3.0("Quit" :command com-quit-exop)
	   ))

(clim:define-command-table 
    EXOP-EDIT-MENU-COMMAND-TABLE
    :menu (("Reallocate marked examples" :command com-reallocate-marked)
           ("Divider1" :divider nil)
	   ("Accept marked generated as target" :command com-accept-generated)
	   ("Accept marked targets as glosses" 
	    :command com-accept-target-as-gloss)
	   ("Accept marked glosses as targets"
	    :command com-accept-gloss-as-target)
	   ("Accept marked generated as glosses"
	    :command com-accept-generated-as-gloss)
           ("Divider2" :divider nil)
	   ("Clear loaded examples" :command com-clear-examples-em)
	   ("Undelete some deleted examples" :command com-undelete-example-em)
           ("Divider3" :divider nil)
           ("Make dated marked examples" :command com-date-exset)
           ("Undate marked examples" :command com-undate-exset)
           ("Divider4" :divider nil)
	   ("Inspect generated/target mismatches"
	    :command com-start-mismatch-inspector)
	   ))

(clim:define-command-table 
 EXOP-GENERATE-TABLE
 :menu (("Generate Next" :command com-generate-exop-next)
	("Generate Next Marked" :command com-generate-exop-next-marked)
	("Generate Next Ungenerated" :command com-generate-next-ungenerated)
	("Generate Next with target/generated mismatch"
	 :command com-generate-next-mismatched)
	("Generate" :command com-generate-sentence-em)
	("Generate again" :command com-generate-again-em)
	;; 4.0 moved here as it is more logical than where Lispworks was putting it...
	("Divider1" :divider nil)
	#+lispworks 
	("Structure" :command com-graph-structure-em)
	("Divider2" :divider nil)
	("Example runner" :menu exop-runner-table)))

(clim:define-command-table 
 EXOP-MARKING-TABLE
 :menu (("Mark all" :command com-mark-all-examples)
	("Mark none" :command com-mark-no-examples)
	("Mark generated/target mismatches" :command com-mark-mismatches)
	("Mark generated/target matches" :command com-mark-matches)
	("Mark already generated" :command com-mark-generated)
	("Mark not yet generated" :command com-mark-ungenerated)
	("Invert marked/unmarked" :command com-invert-marking)
	("Mark all examples with collected features" 
	 :command com-mark-collected)
	("Mark all examples containing substring" 
	 :command com-mark-containing-substring)
	("Mark an exercise set" :command com-exop-mark-exset)))

(clim:define-command-table 
 EXOP-CLEARING-TABLE
 :menu (("Clear marking" :command com-mark-no-examples)
	("Clear all examples" :command com-clear-examples-em)
	("Clear shown examples" :command com-clear-shown-examples)
	("Clear marked examples" :command com-clear-marked-examples)
	("Clear generation information" :command com-clear-generation-info)))

(clim:define-command-table 
 EXOP-RUNNER-TABLE
 :menu (("Example runner on all examples shown" 
	 :command com-run-example-runner)
	("Example runner on examples marked" 
	 :command com-run-example-runner-on-marked-examples)
	("Example runner on all examples loaded"
	 :command com-run-example-runner-on-all)
	("Divider1" :divider :line)
	("Inspect generated/target mismatches"
	 :command com-start-mismatch-inspector)
        ("Compare example set versions" :command com-compare-exsets)
        ("Divider2" :divider :line)
	("Features used in examples survey" :command com-survey)))


;; 4.1, December 2007
(clim:define-command-table 
 EXOP-REGRESSION-TABLE
 :menu (("Regression test on all examples shown" 
	 :command com-regression)
	("Regression test on examples marked" 
	 :command com-regression-on-marked-examples)
	("Example runner on all examples loaded"
	 :command com-regression-on-all)
        ))


;;; ----------------------------------------------------------------------
;;; Menu cleaned up and max complexity option added.
;;; 3.2.47 added control of default example set and default SPL name
;;;        for examples created dynamically during generation of 
;;;        unnamed SPLs.
;;; 3.2.52 added a check for same named examples being loaded, so
;;;        that we can be extra careful about things getting lost
;;;        when loading many example files at the same time.
;;;
(clim:define-command-table 
 EXOP-MODES-TABLE
 :menu (("Toggle current language restriction" :command com-exop-lg-restricted)
	("Toggle alphabetical listing" :command com-exop-alpha)
	("Toggle marked first listing" :command com-exop-marked-first)
	("Toggle display of exercise set names" :command com-exop-exset-names)
	("Toggle display of strings" :command com-exop-show-strings)
	("Toggle string abbreviation" :command com-exop-abbrev-strings)
	("Toggle targetted/generated" :command com-exop-target-generated)
	("divider1" :divider nil)
	("Toggle including punctuation in mismatch status"
	 :command com-exop-punctuation-in-mismatch)
	;; 2.0.47
	("Toggle case-sensitivity in mismatch status"
	 :command com-exop-case-sensitivity-in-mismatch)
	("Toggle full example structure saving" 
	 :command com-exop-full-structure)
	("divider2" :divider nil)
	("Set current language" :command com-set-language-em)
        ("Set current gloss language" :command com-set-gloss-language)
	;; 3.2.52
	("Toggle checking duplicates on loading" 
	 :command com-toggle-check-dups)
	("divider3" :divider nil)
	("Select example set" :command com-exop-select-exset)
	;; 3.2.47
	("Set default example and example set names"
	 :command com-exop-set-ex-names)
	("Generation modes" :command com-generation-display-modes-em)
	;; 3.2.17
	("Set maximum generation complexity" :command com-set-max-complexity)
	("Highlight" :menu exop-highlighting-options)
	))
 
(clim:define-command-table
    EXOP-HIGHLIGHTING-OPTIONS
    :menu (("Toggle examples using collected features" 
	    :command com-exop-show-instances-using-collecteds)
	   ("Using collected features in a single selection expression"
	    :command com-exop-collected-features-in-single-se)
	   ("Using all collected features somewhere"
	    :command com-exop-collected-features-anywhere)
	   ("Using some collected features somewhere"
	    :command com-exop-collected-feature-anywhere)))

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

(clim:define-application-frame EXAMPLE-OPERATIONS-FRAME ()
  ( (lg-restriction :initform T) 
    (exlist :initform nil)
    (highlighted :initform '(:collected)) ;; show these examples highlighted
    (alpha :initform T)
    (markedfirst :initform nil)           ;; 4.1 group marked together first
    (abbrev :initform T)
    (glosses-shown :initform T)
    (display-string :initform :target)
    (ex-set-shown :initform nil)          ;; currently focused exset
    (display-exset-name :initform nil)    ;; show exset names in frame
    (marked-set :initform nil)
    )
  (:menu-bar T)
  (:top-level (clim:default-frame-top-level))
  (:command-table 
   (example-operation-commands
    :inherit-from (flag-bar-frame)        ;; 2.1
    :menu
    (("File" :menu exop-file-menu-command-table)
     ("Edit" :menu exop-edit-menu-command-table)
     ("Generate" :menu exop-generate-table)
     #-lispworks
     ("Structure" :command com-graph-structure-em)     ;; 4.0 Lispworks groups this
                                                          ;;     under a generic menu bar
                                                          ;;     item, which is not sensible
                                                          ;;     so conditionalize out and
                                                          ;;     here and place under Generate menu
     ("Mark" :menu exop-marking-table)
     ("Clear" :menu exop-clearing-table)
     ("Modes" :menu exop-modes-table)
     ("Runner" :menu exop-runner-table)
     ("Regression" :menu exop-regression-table)
     ("Redisplay" :command com-redisplay-example-list)
     ))) 
  (:panes 
   (exset-list   :application
		 :foreground interactor-fg
		 :background interactor-bg
		 :incremental-redisplay T
		 :display-after-commands T
		 :end-of-line-action :allow
		 :end-of-page-action :allow
		 :initial-cursor-visibility :inactive
		 :display-function 'exset-list-displayer
		 :text-style *sans-serif--bold--10*
		 :scroll-bars :vertical)
   (example-list :application
		 :foreground interactor-fg
		 :background interactor-bg
		 :incremental-redisplay T
		 :display-after-commands T
		 :end-of-line-action :allow
		 :end-of-page-action :allow
		 :initial-cursor-visibility :inactive
		 :display-function 'example-list-displayer
		 :text-style *sans-serif--bold--10*
		 :scroll-bars :both)
   (flag-bar   :application                       ;; 2.1
	  :display-function 'flag-bar-displayer
	  :height 20
	  :scroll-bars nil
	  :incremental-redisplay T
	  :initial-cursor-visibility :inactive
	  :foreground  flag-bar-fg
	  :background  mouse-doc-bg)
   (mouse-doc   :pointer-documentation
		:foreground  mouse-doc-fg
		:background  mouse-doc-bg))
  (:layouts 
   #+(and :kpml-level>= :kpml-l2)	
   (first 
    (clim:vertically
	()
      (:fill example-list)
      (#+lispworks 1/4 #-lispworks 80 exset-list)
      (2/32 flag-bar)                    ;; 2.1
      (2/32 mouse-doc)))
   #-(and :kpml-level>= :kpml-l2)	
   (first 
    (clim:vertically
	()
      (:fill example-list)
      (#+lispworks 1/4 #-lispworks 80 exset-list)
      (2/32 mouse-doc)))
   ))

;;; Presentation types...

(clim:define-presentation-type exset-name ())

(clim:define-presentation-action present-exset-name
    (exset-name nil example-operation-commands
		:documentation "Restrict view to this example set")
  (object)
  (with-slots (ex-set-shown) 
      clim:*application-frame*
    (setf ex-set-shown object)
    (com-redisplay-example-list)))

;;; ----------------------------------------------------------------------
;;; Example name operations...

(define-example-operations-frame-command 
    (com-TOGGLE-EXAMPLE-MARK
     :name "Mark/Unmark example" :menu nil)
    ((example-name 'example-name :gesture :select))
  (with-slots (marked-set) clim:*application-frame*
    (if (member example-name marked-set)
	(setf marked-set (remove example-name marked-set))
      (push example-name marked-set))
    (setf *currently-marked* marked-set)))

;;; More example operations, basically redoing those that would have been
;;; inherited from development, but adding in the unforced redisplay
;;; of the example list when necessary (also avoiding multiple inheritance
;;; from both the development frame and the inspection frame when in
;;; extended single window mode).

(define-example-operations-frame-command 
    (com-GRAPH-EXAMPLE-EM :name "Graph example structure" :menu nil)
    ((example-name 'example-name :gesture :menu))
  (com-graph-example-2 example-name))

(define-example-operations-frame-command 
    (com-GRAPH-STRUCTURE-EM :name "Structure" :menu T)
    ()
  (graph-sentence-structure))

(define-example-operations-frame-command 
    (com-DISPLAY-STRING-OF-EXAMPLE-EM
     :name "Display generated string" :menu nil)
    ((example-name 'example-name :gesture :menu))
  (com-display-string-of-example-2 example-name))

;;; ----------------------------------------------------------------------
;;; 2.0.13
;;; The example operations allowed copying but not renaming. Useful
;;; to have both options present. Added here.
;;; ----------------------------------------------------------------------

;;; 2.0.13 was called rename, now copy...
(define-example-operations-frame-command 
    (com-COPY-EXAMPLE-EM :name "Copy example" :menu nil)
    ((example-name 'example-name :gesture :menu))
  (example-renamer example-name)
  (com-redisplay-example-list))

;;; 2.0.13 real rename (copy and delete) added.
(define-example-operations-frame-command 
    (com-RENAME-EXAMPLE-EM :name "Rename example" :menu nil)
    ((example-name 'example-name :gesture :menu))
  (example-renamer example-name)
  (com-delete-example-em example-name))

(define-example-operations-frame-command 
    (com-DELETE-EXAMPLE-EM :name "Delete example" :menu nil)
  ((example-name 'example-name :gesture :menu))
  (push (cons example-name
	      (kpml::fetch-example-info example-name 'kpml::everything))
	*example-manager-deleted*)
  (kpml::delete-example example-name)
  (com-redisplay-example-list))

(define-example-operations-frame-command 
  (com-UNDELETE-EXAMPLE-EM :name "Undelete some examples" :menu nil)
    ()
    (let ((selection
	   #-(and acl3.0 aclpc)
	   (let ((stream 
		  (clim::frame-top-level-sheet clim:*application-frame*))
		 (value nil))
	     (clim:accepting-values
		 (stream :own-window T
			 :resynchronize-every-pass t
			 :label "Undelete examples")
	       (setf value
		 (clim:accept `(clim:subset-sequence 
				,(mapcar #'car *example-manager-deleted*))
			      :stream stream
			      :view #-lispworks 'clim:list-pane-view 
			            #+lispworks clim:+textual-dialog-view+
			      :prompt "Undelete"
			      :default value))))
	   #+(and acl3.0 aclpc)
	   (kpml::get-a-subset-from 
	    (mapcar #'car *example-manager-deleted*) 
	    nil "Undelete:")))
      (loop for s in selection
	    as definition = (cdr (assoc s *example-manager-deleted*))
	    do 
	    (setf (gethash s kpml::penexamples) definition)
	    (push (reverse (kpml::example-name definition))
		  kpml::examples))
      (setf *example-manager-deleted*
	(remove-if #'(lambda (x) (member (first x) selection))
		   *example-manager-deleted*))
      (com-redisplay-example-list)))

;;; And another specifically for the example manager...

(define-example-operations-frame-command 
    (com-ALLOCATE-EXSET :name "Allocate to example set" :menu nil)
    ((example-name 'example-name :gesture :menu))
  (let ((selection (select-a-possibly-new-example-set nil)))
    (when selection
      (setf (kpml::fetch-example-info example-name 'kpml::set-name)
	selection)
      (com-redisplay-example-list))))
	
;;; ----------------------------------------------------------------------
;;; 2.1 following command takes the current example set, and renames both
;;;     it and all its members, to include the current date. This is to
;;;     support successive regression checks. All the marked examples are
;;;     moved to a dated example set with names changed correspondingly.
;;; ----------------------------------------------------------------------

(define-example-operations-frame-command 
    (com-DATE-EXSET :name "Make dated marked examples" :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
           (loop for example-name in marked-set
                 as new-name = (new-example-name 
                                example-name :hms nil) ;; make name per day not per second
                 when (kpml::example-defined-for-lg-p example-name kpml::curlan)
                 do 
                 (kpml::rename-example example-name new-name)
                 (setf (kpml::fetch-example-info new-name 'kpml::set-name)
                       (new-example-name 
                        (kpml::fetch-example-info example-name 'kpml::set-name)
                        :hms nil)))
           (com-redisplay-example-list))
          (t
           (clim:notify-user
            clim:*application-frame*
            "No examples marked. First mark those to be dated.")))))
  
(define-example-operations-frame-command 
    (com-UNDATE-EXSET :name "Undate marked examples" :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
           (loop for example-name in marked-set
                 as trimmed-name = (trim-date-from-name example-name)
                 when (kpml::example-defined-for-lg-p example-name kpml::curlan)
                 do
                 (kpml::rename-example example-name trimmed-name)
                 (setf (kpml::fetch-example-info trimmed-name 'kpml::set-name)
                       (trim-date-from-name 
                        (kpml::fetch-example-info example-name 'kpml::set-name)))
                 (kpml::delete-example example-name))
           (com-redisplay-example-list))
          (t
           (clim:notify-user
            clim:*application-frame*
            "No examples marked. First mark those to be undated.")))))

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

(defun SELECT-A-POSSIBLY-NEW-EXAMPLE-SET (default)
  (let ((selection (select-an-example-set default  :|new example set|)))
    (cond ((equal selection :|new example set|)
	   (setf selection 
	     (intern
	      (let ((result "new exercise set name")
		    (stream 
		     (clim::frame-top-level-sheet clim:*application-frame*)))
		(clim:accepting-values
		    (#-acl3.0 stream #+acl3.0 *query-io* 
			      :own-window *wide-own-window*
                              :label "New exercise set name"
			      :exit-boxes 
			      '((:exit "Accept")(:abort "Abort")))
		  (setq result 
		    (clim:accept 'clim:string
				 #+lispworks :view
				 #+lispworks clim:+textual-dialog-view+
				 :stream #-acl3.0 stream #+acl3.0 *query-io*
				 :default result
				 :prompt "New exercise set"))
		  (kpml-i-terpri stream)
                  #+lispworks (kpml-i::dialog-end-spacing)
		  result)) "KPML")))
	  (t selection))))

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

(define-example-operations-frame-command 
    (com-REDISPLAY-EXAMPLE-LIST :name "Redisplay" :menu T)
    ()
  (with-slots (exlist lg-restriction)
   clim:*application-frame*
   (setf exlist nil)
   (setf *currently-focused-examples* nil)
   (kpml::actualize-list-of-example-sets-loaded lg-restriction)
   (clim:redisplay-frame-pane 
    clim:*application-frame* 'example-list :force-p t)
   (clim:redisplay-frame-pane 
    clim:*application-frame* 'exset-list :force-p t)))

#-acl3.0
(define-example-operations-frame-command 
    (com-QUIT-EXOP :name "Quit" :menu nil)
    ()
  (setf *ex-op-frame* nil)
  (close-a-window clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; The display function...

(defmethod EXSET-LIST-DISPLAYER ((frame example-operations-frame) stream)
  (with-slots (lg-restriction) frame
    (clim:with-end-of-line-action (stream :wrap)
      (clim:updating-output 
	  (stream :cache-value (cons lg-restriction kpml::curlan))
        (clim:with-text-face 
	    (stream '(:bold :italic))
          (kpml::actualize-list-of-example-sets-loaded lg-restriction)
          (if lg-restriction
	      (format stream "~%~0TExample sets for ~A loaded..." kpml::curlan)
            (format stream "~%~0TExample sets loaded..."))))
      (clim:updating-output 
	  (stream :cache-value (sxhash kpml::*ex-sets*))
        (loop for ex in kpml::*ex-sets*
	      do (clim:with-output-as-presentation
		     (stream ex 'exset-name)
	           (format stream " ~A" ex)))))))

(defmethod EXAMPLE-LIST-DISPLAYER ((frame example-operations-frame) stream)
  (with-slots 
      (exlist lg-restriction alpha display-string ex-set-shown marked-set
       display-exset-name highlighted abbrev glosses-shown markedfirst)
      clim:*application-frame*
    (let ((marked-set-holder marked-set))
      (declare (special marked-set-holder))
    (unless exlist 
      (setf exlist
	(example-selector :differences-mode nil
			  :ex-set-name ex-set-shown
			  :alpha? alpha
			  :markedfirst? markedfirst       ;; 4.1
			  :restrict-by-lg lg-restriction
			  :display-mode display-string)))
    (clim:stream-set-cursor-position stream 0 0)
    (clim:with-text-style 
	(stream *sans-serif--roman--12*)
      (clim:updating-output
	  (stream :cache-value kpml::curlan)
	(format stream "~%~0TCurrent language is: ~A" kpml::curlan))
      (clim:updating-output
	  (stream :cache-value ex-set-shown)
	(format stream "~%~0TExample set shown: ~A (~A examples)~2%"
		(if ex-set-shown ex-set-shown :all)
                (length exlist))))
    (clim:formatting-table 
	(stream :move-cursor nil)
      (clim:updating-output
	  (stream 
	   :cache-value 
	   (sxhash (list kpml::curlan display-string display-exset-name))
           )
	(clim:formatting-row (stream)
	  (clim:with-text-style (stream *sans-serif--italic--8*)
	    (clim:formatting-cell (stream)
	      (format stream "marked"))
	    (clim:formatting-cell (stream)
	      (format stream "    name"))
	    (when display-exset-name
	      (clim:formatting-cell (stream)
		(format stream " ex set")))
	    (unless (equal display-string :none)
	      (clim:formatting-cell (stream)
		(format stream "    ~A" display-string)))
	    (clim:formatting-cell (stream)
	      (format stream "generated?"))
	    (clim:formatting-cell (stream)
	      (format stream "mismatch?")))))
      (setf *focused-exercise-set* ex-set-shown)
      (setf *currently-focused-examples* exlist)
      (setf *currently-marked* marked-set)
      (loop for e in exlist
	  when (kpml::example-p e)
	  do (clim:formatting-row (stream)
	       (multiple-value-bind 
		   (string generation-status mismatch)
		   (fetch-example-information e display-string abbrev)
		 (clim:updating-output 
		     (stream :cache-value (member e marked-set))
		   (clim:formatting-cell (stream)
		     (when (member e marked-set)
		       (kpml-tick stream :color clim:+red+))))
		 (let ((highlight? (and (member :collected highlighted)
					(kpml::example-uses-features-p e))))
		   (clim:updating-output
		       (stream :cache-value (list highlight? e
						  kpml::*most-recent-example*)
			       :cache-test #'equal)
		     (clim:formatting-cell (stream)
		       (clim:with-output-as-presentation 
			   (stream e 'example-name)
			 (macrolet ((do-it ()
				      '(if (equal e 
					    kpml::*most-recent-example*)
					(clim:surrounding-output-with-border
					    (stream :shape :underline)
					  (format stream "~A" e))
					(format stream "~A" e))))
			   (if highlight?
			       (clim:with-text-face 
				(stream '(:bold :italic))
				(clim:with-drawing-options 
				 (stream 
				  :ink (if (kpml::example-defined-for-lg-p
					    e kpml::curlan)
					   clim:+magenta+
					 *grey*))
				 (do-it)))
			     (if (kpml::example-defined-for-lg-p e kpml::curlan)
				 (do-it)
			     (clim:with-drawing-options (stream :ink *grey*)
							(do-it)))))))))
		 (when display-exset-name
		       (let ((exset (kpml::fetch-example-info 
				     e 'kpml::set-name)))
			 (clim:updating-output
			  (stream :cache-value exset)
			  (clim:formatting-cell 
			   (stream)
			   (clim:with-text-style (stream *sans-serif--bold--8*)
						 (format stream "(~A)" exset))))))

		 (unless (equal display-string :none)
		   (clim:formatting-cell (stream)
		     (clim:updating-output
			 (stream :cache-value (sxhash display-string)
				 :cache-test #'equal)
		       (with-conditional-font-changes-for-language 
			   (stream kpml::curlan)
			 (if abbrev
			     (format stream "~A" string)
			   (clim:filling-output
			       (stream 
				:fill-width 
				`(,*example-menu-width* :character))
			     (format stream "~A" string)))))
		     (clim:updating-output
			 (stream :cache-value glosses-shown)
		       (when glosses-shown 
			 (clim:filling-output
			     (stream 
			      :fill-width 
			      `(,*example-menu-width* :character))
			   (show-gloss e stream)))
		       )))

		 (clim:updating-output
		     (stream :cache-value (list generation-status mismatch)
			     :cache-test #'equal)
		   (clim:formatting-cell (stream)
		     (when generation-status 
		       (kpml-tick stream :color clim:+blue+)))
		   (clim:formatting-cell (stream)
		     (when mismatch 
		       (kpml-tick stream :color clim:+red+))))))))
    (format stream "~%~0T"))))
      

;;; ----------------------------------------------------------------------
;;; Frame startups as usual...

(defun STARTUP-EXAMPLE-OPERATIONS-FRAME (&optional (reset nil))
  #-acl3.0(when (and reset *ex-op-frame*)
		(close-a-window *ex-op-frame*)
		(setf *ex-op-frame* nil))
  (startup-example-operations-frame-internal :reset reset))

;;; ----------------------------------------------------------------------
;;; For displaying glosses...
;;; ----------------------------------------------------------------------

(defun SHOW-GLOSS (ex &optional (stream T))
  (let ((gloss (kpml::fetch-example-info ex 'kpml::gloss)))
    (when gloss
      (with-conditional-font-changes-for-language 
	  (stream kpml::curlan)
          (clim:with-text-face (stream :italic)
	    (clim:with-text-size (stream :smaller)
	      (format stream "~%(~A)" gloss)))))))

;;; ----------------------------------------------------------------------
;;; Management functions, gathered here from elsewhere when relevant
;;; and additions as required for the above functionality...
;;; ----------------------------------------------------------------------

(defun EXAMPLE-RENAMER (example-name)
  (let ((new-name example-name)
	(stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (restart-case
	(clim:accepting-values
	    (#-acl3.0 stream #+acl3.0 *query-io* 
		      :own-window *wide-own-window*
		      :scroll-bars :horizontal
		      :label 
		      (concatenate 'string 
			"Copy and rename example: "
			(string example-name))
		    :exit-boxes '((:exit "Rename")(:abort "Abort renaming")))
	  (setq new-name 
	    (clim:accept 
	     'clim:symbol 
	     #+lispworks :view #+lispworks clim:+textual-dialog-view+
	     :stream #-acl3.0 stream  #+acl3.0 *query-io*
	     :default new-name
	     :prompt "New name"))
	  (kpml-i-terpri stream))
      (abort () (return-from EXAMPLE-RENAMER nil)))
    (kpml::rename-example example-name new-name)))

(defun NEW-EXAMPLE-NAME (example-name &key (hms t))
  (multiple-value-bind 
   (second minute hour date month year) 
   (get-decoded-time)
   (intern
    (if hms (format nil "~a[~2,'0D-~2,'0D-~2,'0D]" 
		    example-name hour minute second)
      (format nil "~a[~2,'0D-~2,'0D-~2,'0D]" 
	      example-name year month date))
    "KPML")))

(defun TRIM-DATE-FROM-NAME (dated-name &key (package (find-package "KPML")))
  (let* ((name (symbol-name dated-name))
         (position (position #\[ name)))
    (if position
        (let ((symbol (find-symbol (subseq name 0 position) package)))
          (if symbol symbol
            (intern (subseq name 0 position) package)))
      dated-name)))

;;;----------------------------------------------------------------------
;;; 1.1 originals of these functions were in general-facilities.lisp
;;;     gathered here and functionality made more coherent.
;;;
;;; a.  Additions for handling examples more usefully, using
;;;     modes and selection options for restricting the
;;;     range of examples offered for generation.
;;;
;;; Following is the basic function that returns the currently 
;;; `relevant' list of examples that are being considered for generation,
;;; etc. Generally improved and made more resilient for 1.1.
;;; 
;;; 2.0.25 ordering improved.
;;; 4.1    added option of grouping together the marked examples first
;;; ----------------------------------------------------------------------

(defun EXAMPLE-SELECTOR 
    (&key (alpha? *list-examples-alphabetically*)
	  (markedfirst? *list-marked-examples-first*)       ;; 4.1
	  (restrict-by-lg kpml::*restrict-example-running-by-language*)
	  (display-mode *example-display-desired-mode*)
	  (differences-mode *example-differences-mode*)
	  (ex-set-name *focused-exercise-set*))
  (let* ((examples0
	  (if *currently-focused-examples*
	      *currently-focused-examples*
	    (remove-duplicates 
	     (if restrict-by-lg (kpml::list-of-examples)
	       (mapcar #'first kpml::examples)))))
	 (examples 
	  (if ex-set-name
	      (loop for ex in examples0
		  when (equal (kpml::fetch-example-info ex 'kpml::set-name)
			      ex-set-name)
		  collect ex)
	    examples0))
	 (exlist
	  (cond (display-mode examples)
		(differences-mode
		 (loop for e in examples
		       unless (kpml::target-generated-match-p e)
		       collect e))
		(t
		 examples))))
    (declare (special marked-set-holder))
    ;; 2.0.25
    (when alpha? 
      (setf exlist (sort exlist #'kpml::numbered-name-lessp)))
    ;; 4.1
    (when markedfirst? 
      (setf exlist (pull-out-marked-examples exlist)))
    exlist
    ))

;;; Following function added for 0.9 (and available as 0.8.28): changes
;;; the range of options considered when displaying the example menu. 
;;; The value of the flag *example-display-desired-mode* is now one of
;;; nil (no display), :target (the target form is displayed), :generated
;;; (the last generated form is displayed).

(defun EXAMPLE-DISPLAY-FORM (example-name)
  (let ((overflow nil))
    (concatenate
	'string
      (symbol-name example-name)
      (if *example-display-desired-mode* ":  " "")
      (case *example-display-desired-mode*
	(:target 
	 (let ((string 
		(kpml::fetch-example-info example-name 
					    'kpml::targetform)))
	   (setf overflow (> (length string) *example-menu-width*))
	   (subseq string 0 (min *example-menu-width* (length string)))))
	(:generated
	 (let ((string 
		(kpml::fetch-example-info example-name 
					    'kpml::generatedform)))
	   (setf overflow (> (length string) *example-menu-width*))
	   (subseq string 0 (min *example-menu-width* (length string)))))
	(:otherwise ""))
      (if overflow "... " "")
      )))


;;; 0.9: Following is changed completely making use of better menus...
;;;      Abort restart case added...

(defun POSSIBLY-LARGE-EXAMPLE-MENU-CHOOSE (choices max)
  (declare (ignore max))
  (let ((example-to-generate nil)
	(stream 
	 #-lispworks(clim::frame-top-level-sheet clim:*application-frame*)
	 #+lispworks(clim::frame-top-level-sheet *resource-development-frame*))
	(pane (clim:get-frame-pane *resource-development-frame* 'inspector)))
    (when (= (length choices) 0)
      (clim:notify-user stream "No appropriate examples loaded.")
      (return-from POSSIBLY-LARGE-EXAMPLE-MENU-CHOOSE nil))
    (if (equal (length choices) 1)
	(first choices)
      (progn
	(restart-case 
	 (clim:accepting-values
	  (#+acl3.0 *query-io* #-acl3.0 stream :own-window *own-window*
                    :scroll-bars :vertical
		    :resynchronize-every-pass T
		    :label "Select an example for generation/examination" 
		    :exit-boxes 
		    '((:exit "Click here when selection made")
		      (:abort "Click here to cancel")))
	  (kpml-i-terpri #+acl3.0 *query-io* #-acl3.0 stream)
	  (setf example-to-generate
		(clim:accept `(clim:member-sequence 
			       ,(mapcar 
				 #'(lambda (example-name)
				     (cons
				      (example-display-form example-name)
				      example-name))
				 choices)
			       :test ,#'common-lisp:equal)
			     :view #-lispworks 'clim:list-pane-view
                                   #+lispworks clim:+textual-dialog-view+
			     :stream #+acl3.0 *query-io* #-acl3.0 stream
			     :prompt ""
			     :default example-to-generate))
          #+lispworks (kpml-i::dialog-end-spacing))
	 (ABORT () (format pane "~%Selection aborted.~%")))
	(rest example-to-generate)))))

;;; ----------------------------------------------------------------------0
;;; 

(defun FETCH-EXAMPLE-INFORMATION (example-name display-string-mode abbrev-mode)
  (let (string generation-status mismatch
	(target (kpml::clean-up-final-string
		 (kpml::fetch-example-info example-name 'kpml::targetform)))
	(gen (kpml::clean-up-final-string
	      (kpml::fetch-example-info example-name 'kpml::generatedform))))
    (setf string
      (case display-string-mode
	(:target target)
	(:generated gen)
	(:none nil)))
    (if (and gen (stringp gen))
	;; 2.0.14 mismatch predicate extended...
	(setf mismatch (kpml::generation-mismatch-p target gen))
      (setf mismatch nil))
    (setf generation-status
      (if (kpml::fetch-example-info example-name 'kpml::structure) T nil))
    (values 
     (if (and abbrev-mode
	      (> (length string) *example-menu-width*))
	 (concatenate 'string
	   (subseq string 0 (min *example-menu-width* (length string)))
	   "...")
       string)
     generation-status mismatch)))

;;; ----------------------------------------------------------------------
;;; 2.1 new function based on the above that compares with a corresponding
;;;     named example from the specified example set. If no such example
;;;     is found, the string "no comparison" appears... Is used as follows.
;;;     Is called for some example-name with a comparison exercise set
;;;     identified. If the mode is :standard, then it returns the corresponding
;;;     generated string of the comparison exercise set. If the mode is
;;;     :comparison, then it returns the generated string of the example-name.
;;; ----------------------------------------------------------------------

(defun FETCH-EXAMPLE-COMPARISON-INFORMATION (example-name comparison-ex-set mode)
  (let (generation-status mismatch
	 (target (kpml::clean-up-final-string
                  (loop for ex in (kpml::list-of-examples)
                        when (and (equal (trim-date-from-name ex) example-name)
                                  (equal 
                                   (kpml::fetch-example-info ex 'kpml::set-name)
                                   comparison-ex-set))
                        do (return (kpml::fetch-example-info ex 'kpml::generatedform))
                        finally (return "no comparison"))))
	(gen (kpml::clean-up-final-string
	      (kpml::fetch-example-info example-name 'kpml::generatedform))))
    (if (and gen (stringp gen))
        ;; 2.0.14 mismatch predicate extended...
        (setf mismatch (kpml::generation-mismatch-p target gen))
      (setf mismatch nil))
    (setf generation-status
          (if (kpml::fetch-example-info example-name 'kpml::structure) T nil))
    (case mode
      (:standard
       (values target generation-status mismatch))
      (:comparison
       (values gen generation-status mismatch))
      )))

;;; ----------------------------------------------------------------------
;;; Example operation: extra file and editing commands...


;;; N.B. FOLLOWING REBINDS THE GLOBAL VARIABLE KPML::EXAMPLES IN ORDER TO
;;; AFFECT WHICH EXAMPLES ARE WRITTEN OUT...

(define-example-operations-frame-command 
    (com-WRITE-EXAMPLE-SET :name t :menu nil)
    ()
  (with-slots (lg-restriction ex-set-shown) clim:*application-frame*
    (let ((selection (if ex-set-shown
			 ex-set-shown
		       (progn
			 (kpml::actualize-list-of-example-sets-loaded lg-restriction)
			 (select-an-example-set ex-set-shown)))))
      (if (eq selection :all)
	  (com-write-example-files)
	(let ((kpml::examples 
	       (loop for ex in (kpml::list-of-examples 
				(if lg-restriction kpml::curlan nil))
		   when (equal 
			 (kpml::fetch-example-info ex 'kpml::set-name) 
			 selection)
		   collect (cons ex 
				 (if lg-restriction (list kpml::curlan)
				   (kpml::fetch-example-info 
				    ex 'kpml::ls-set))))))
	  (declare (special kpml::examples))
          ;; 2.1 make sure that messages only get delivered to the development frame...
          (let ((*standard-output* 
                 (or (clim::get-frame-pane *resource-development-frame* 'inspector)
                     (clim::get-frame-pane *resource-manager-frame* 'inspector))))
            (kpml::interface-example-saving)))))))


  ;; 3.2.8 was not resetting code page during loading of the file.
  ;;
(define-example-operations-frame-command 
    (com-reload-last-example-file :name "Reload Last File" :menu nil)
    ()
  (if kpml::*last-loaded-example-file*
      (let ((*standard-output* *trace-output*))
	(kpml::with-code-page-settings 
	 (kpml::curlan)
	 (kpml::kpml-load kpml::*last-loaded-example-file*)))
    (com-load-example-files)))

(define-example-operations-frame-command 
    (com-save-marked-examples :name t :menu nil)
    ()
  (with-slots (marked-set lg-restriction) clim:*application-frame*
    (cond (marked-set
	   (let ((kpml::examples 
		  (loop for ex in marked-set
			collect (cons ex (if lg-restriction (list kpml::curlan)
					   (kpml::fetch-example-info 
					    ex 'kpml::ls-set))))))
	     (declare (special kpml::examples))
	     (kpml::interface-example-saving)))
	  (t
	   (clim:notify-user clim:*application-frame*
			     "No examples marked.")))))


(define-example-operations-frame-command 
    (com-REALLOCATE-MARKED :name t :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
   (cond (marked-set
	  (let ((selection (select-a-possibly-new-example-set nil)))
	    (when selection
	      (loop for e in marked-set
		    do (setf (kpml::fetch-example-info e 'kpml::set-name)
			     selection))
	      (com-redisplay-example-list))))
	 (t
	  (clim:notify-user clim:*application-frame*
			    "No examples marked.")))))

(define-example-operations-frame-command 
    (com-ACCEPT-GENERATED 
     :name "Accept marked generated strings as targets"  :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (loop for e in marked-set
	do (setf (kpml::fetch-example-info e 'kpml::targetform)
	     (kpml::fetch-example-info e 'kpml::generatedform)))
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t)))

;;; 2.1 additions for glosses...

(define-example-operations-frame-command 
    (com-ACCEPT-TARGET-AS-GLOSS
     :name "Accept marked targets as glosses"  :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (loop for e in marked-set
	do (setf (kpml::fetch-example-info e 'kpml::gloss)
	     (kpml::fetch-example-info e 'kpml::targetform)))
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p nil)))

(define-example-operations-frame-command 
    (com-ACCEPT-GLOSS-AS-TARGET
     :name "Accept marked glosses as targets"  :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
	   (loop for e in marked-set
		 do (setf (kpml::fetch-example-info e 'kpml::targetform)
			  (kpml::fetch-example-info e 'kpml::gloss)))
	   (clim:redisplay-frame-pane 
	    clim:*application-frame* 'example-list :force-p nil))
	  (t
	    (clim:notify-user clim:*application-frame*
			      "No examples marked.")))))

(define-example-operations-frame-command 
    (com-ACCEPT-GENERATED-AS-GLOSS
     :name "Accept marked generated as glosses"  :menu nil)
    ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
	   (loop for e in marked-set
		 do (setf (kpml::fetch-example-info e 'kpml::gloss)
			  (kpml::fetch-example-info e 'kpml::generatedform)))
	   (clim:redisplay-frame-pane 
	    clim:*application-frame* 'example-list :force-p nil))
	  (t
	    (clim:notify-user clim:*application-frame*
			      "No examples marked.")))))

;;; ----------------------------------------------------------------------
;;; Example operation: marking commands...

(define-example-operations-frame-command 
  (com-MARK-ALL-EXAMPLES :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (setf marked-set exlist)))

(define-example-operations-frame-command 
  (com-MARK-NO-EXAMPLES  :name t :menu nil)
  ()
  (with-slots (marked-set)
	      clim:*application-frame*
	      (setf marked-set nil)))


(define-example-operations-frame-command 
  (com-MARK-MISMATCHES :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (loop for ex in exlist
	 unless (kpml::target-generated-match-p ex)
	 do (pushnew ex marked-set))))

(define-example-operations-frame-command 
  (com-MARK-MATCHES :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (loop for ex in exlist
	 when (kpml::target-generated-match-p ex)
	 do (pushnew ex marked-set))))

(define-example-operations-frame-command 
  (com-MARK-GENERATED :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (loop for ex in exlist
	 when (kpml::fetch-example-info ex 'kpml::structure)
	 do (pushnew ex marked-set))))

(define-example-operations-frame-command 
  (com-MARK-UNGENERATED :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (loop for ex in exlist
	 unless (kpml::fetch-example-info ex 'kpml::structure)
	 do (pushnew ex marked-set))))

(define-example-operations-frame-command 
  (com-INVERT-MARKING :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (setf marked-set
	 (loop for ex in exlist
	       unless (member ex marked-set)
	       collect ex))))

(define-example-operations-frame-command 
  (com-MARK-COLLECTED :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (if kpml::*collected-features*
       (setf marked-set
	     (remove-duplicates
	      (append marked-set
		      (kpml::get-examples-with-features
		       kpml::*collected-features* exlist))))
       (format 
	(clim:get-frame-pane 
		     *resource-development-frame* 'inspector)
	"~%No features have been collected.~%"))))


(define-example-operations-frame-command 
  (com-CLEAR-SHOWN-EXAMPLES :name t :menu nil)
  ()
  (with-slots 
   (exlist marked-set)
   clim:*application-frame*
   (loop for ex in exlist 
       do (kpml::delete-example ex)
	  ;; 2.0.48
	  (setf *currently-focused-examples*
	    (remove ex *currently-focused-examples*))
          (setf exlist (remove ex exlist))
          (setf marked-set (remove ex marked-set)))))

(define-example-operations-frame-command 
  (com-CLEAR-MARKED-EXAMPLES :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (cond (marked-set
	  (loop for ex in marked-set
		do (kpml::delete-example ex)
		;; 2.0.48
		(setf *currently-focused-examples*
		      (remove ex *currently-focused-examples*))
		(setf exlist (remove ex exlist))
		)
	  (setf marked-set nil))
	 (t
	  (clim:notify-user clim:*application-frame*
			    "No examples marked.")))))


;;; 4.1, Bremen, July 2006

(define-example-operations-frame-command 
  (com-MARK-CONTAINING-SUBSTRING :name t :menu nil)
  ()
  (with-slots 
   (marked-set exlist)
   clim:*application-frame*
   (let ((selection (get-a-substring)))
     (unless (string= selection "")
       (setf marked-set (kpml::search-examples-for-substring selection))
       (com-redisplay-example-list)))))

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

(define-example-operations-frame-command 
  (com-CLEAR-GENERATION-INFO :name t :menu nil)
  ()
  (with-slots 
   (exlist)
   clim:*application-frame*
   (loop for ex in exlist
	 do (setf (kpml::fetch-example-info ex 'kpml::structure) nil))))

(define-example-operations-frame-command 
  (com-RUN-EXAMPLE-RUNNER :name t :menu nil)
  ()
  (with-slots (exlist) clim:*application-frame*
    ;; 2.0.61
    (example-runner-noting-progress 
     exlist "Example running (all shown)")))

(define-example-operations-frame-command 
  (com-RUN-EXAMPLE-RUNNER-ON-ALL :name t :menu nil)
  ()
  ;; 2.0.61
  (example-runner-noting-progress 
   (kpml::list-of-examples) "Example running (all examples loaded)"))

(define-example-operations-frame-command 
  (com-RUN-EXAMPLE-RUNNER-ON-MARKED-EXAMPLES :name t :menu nil)
  ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
	   ;; 2.0.61
	   (example-runner-noting-progress 
	    marked-set "Example running (marked examples)"))
	  (t
	   (clim:notify-user clim:*application-frame*
			     "No examples marked.")))))

(define-example-operations-frame-command 
  (com-SURVEY :name t :menu nil)
  ()
  (let ((*standard-output* *trace-output*)
	(kpml::window-interface-flag nil))
    (kpml::feature-survey)))


;;; ----------------------------------------------------------------------
;;; 4.2, Dec 2007. Regression commands on the model of example
;;;                running...

(define-example-operations-frame-command 
  (com-REGRESSION :name t :menu nil)
  ()
  (with-slots (exlist marked-set) clim:*application-frame*
    (let ((diffs (regression-test exlist)))
      (cond (diffs
             (setf marked-set diffs)
             (clim:notify-user clim:*application-frame*
                               (format nil "Regression test shows that ~A examples have been effected. These have now been marked." (length diffs))))
            (t
             (clim:notify-user clim:*application-frame*
                          "Regression test OK. No examples changed."))))))

(define-example-operations-frame-command 
  (com-REGRESSION-ON-ALL :name t :menu nil)
  ()
  (with-slots (marked-set) clim:*application-frame*
    (let ((diffs (regression-test (kpml::list-of-examples))))
      (cond (diffs
             (setf marked-set diffs)
             (clim:notify-user clim:*application-frame*
                               (format nil "Regression test shows that ~A examples have been effected. These have now been marked." (length diffs))))
            (t
             (clim:notify-user clim:*application-frame*
                               "Regression test OK. No examples changed."))))))


(define-example-operations-frame-command 
  (com-REGRESSION-ON-MARKED-EXAMPLES :name t :menu nil)
  ()
  (with-slots (marked-set) clim:*application-frame*
    (cond (marked-set
	   ;; 2.0.61
           (let ((diffs (regression-test marked-set)))
             (cond (diffs
                    (setf marked-set diffs)
                    (clim:notify-user clim:*application-frame*
                                      (format nil "Regression test shows that ~A examples have been effected. These have now been marked." (length diffs))))
                   (t
                    (clim:notify-user clim:*application-frame*
                                     "Regression test OK. No examples changed.")))))
	  (t
	   (clim:notify-user clim:*application-frame*
			     "No examples marked.")))))

;;; ----------------------------------------------------------------------
;;; Mode commands...

(define-example-operations-frame-command 
  (com-EXOP-LG-RESTRICTED :name t :menu nil)
  ()
  (with-slots (lg-restriction exlist) clim:*application-frame*
    (setf lg-restriction (not lg-restriction))
    (com-redisplay-example-list)))

(define-example-operations-frame-command 
  (com-EXOP-ALPHA :name t :menu nil)
  ()
  (with-slots (alpha exlist) clim:*application-frame*
    (setf alpha (not alpha))
    (com-redisplay-example-list)))

(define-example-operations-frame-command             ;; 4.1
  (com-EXOP-MARKED-FIRST :name t :menu nil)
   ()
   (with-slots (markedfirst exlist) clim:*application-frame*
    (setf markedfirst (not markedfirst))
    (com-redisplay-example-list)))

(define-example-operations-frame-command 
    (com-EXOP-EXSET-NAMES :name t :menu nil)
    ()
  (with-slots (display-exset-name) clim:*application-frame*
    (setf display-exset-name (not display-exset-name))
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t)))

(define-example-operations-frame-command 
    (com-EXOP-FULL-STRUCTURE :name t :menu nil)
    ()
 (let ((str-2 (clim:get-frame-pane *resource-development-frame* 'inspector)))
  (setf kpml::*full-example-structures-saved* 
	(not kpml::*full-example-structures-saved*))
  ;; 4.0 should also set the generation flag at this point, otherwise
  ;;     it is unclear to the user what work this toggle achieves!
  (setf kpml::store-to-environment-flag 
    kpml::*full-example-structures-saved*)
  (if kpml::*full-example-structures-saved*
      (format str-2 "~%Full generated example structure saving ON.")
    (format str-2 "~%Full generated example structure saving OFF.")
    )))

(define-example-operations-frame-command 
    (com-EXOP-SHOW-STRINGS :name t :menu nil)
    ()
  (with-slots (display-string) clim:*application-frame*
    (setf display-string
      (case display-string
	(:none :target)
	((:target :generated) :none)))
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t)))

(define-example-operations-frame-command 
    (com-EXOP-ABBREV-STRINGS :name t :menu nil)
    ()
  (with-slots (abbrev) clim:*application-frame*
    (setf abbrev (not abbrev))
    (com-redisplay-example-list)))

(define-example-operations-frame-command 
    (com-EXOP-TARGET-GENERATED :name t :menu nil)
    ()
  (with-slots (display-string) clim:*application-frame*
    (setf display-string
      (case display-string
	(:target :generated)
	(:generated :target)
	(:none :target)))
    (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t)))

(define-example-operations-frame-command 
    (com-EXOP-SHOW-INSTANCES-USING-COLLECTEDS :name t :menu nil)
    ()
  (with-slots (highlighted)
      clim:*application-frame*
    (if (member :collected highlighted)
	(setf highlighted (remove :collected highlighted))
      (push :collected highlighted))))

(define-example-operations-frame-command 
    (com-EXOP-COLLECTED-FEATURES-IN-SINGLE-SE :name t :menu nil)
    ()
  (setf kpml::*example-using-features-condition* :in-same-selexpr))

(define-example-operations-frame-command 
    (com-EXOP-COLLECTED-FEATURES-ANYWHERE :name t :menu nil)
    ()
  (setf kpml::*example-using-features-condition* :anywhere))

(define-example-operations-frame-command 
    (com-EXOP-COLLECTED-FEATURE-ANYWHERE :name t :menu nil)
    ()
  (setf kpml::*example-using-features-condition* :some-feature-anywhere))


(define-example-operations-frame-command 
    (com-EXOP-SELECT-EXSET :name t :menu nil)
    ()
  (with-slots (ex-set-shown exlist lg-restriction)
      clim:*application-frame*
    (kpml::actualize-list-of-example-sets-loaded lg-restriction)
    (let ((selection (select-an-example-set ex-set-shown)))
      (when selection
	(setf ex-set-shown (if (eq selection :all)  nil selection))
	(com-redisplay-example-list)))))

(define-example-operations-frame-command 
    (com-EXOP-MARK-EXSET :name t :menu nil)
    ()
  (with-slots (marked-set ex-set-shown exlist)
      clim:*application-frame*
    (let ((selection (if ex-set-shown
			 ex-set-shown
		       (select-an-example-set ex-set-shown))))
      (if (eq selection :all)
	  (setf marked-set exlist)
	(loop for ex in exlist
	    when (equal 
		  (kpml::fetch-example-info ex 'kpml::set-name) selection)
	    do (pushnew ex marked-set)))
      (clim:redisplay-frame-pane 
       clim:*application-frame* 'example-list :force-p nil))))

   ;; ----------------------------------------------------------------------
   ;; 3.2.55
   ;;   hang over which produces a useful horizontally arrayed dialog
   ;;   box that is not useful when it is wider than the screen.

(defun SELECT-AN-EXAMPLE-SET (default &optional (extra-item :all)(additional-message nil))
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(selection default))
    (restart-case
	(clim:accepting-values
	    (stream :own-window *own-window*
		    :resynchronize-every-pass t
		    :label "Example set selection" 
		    :exit-boxes 
		    '((:exit "Click to accept")(:abort "Click to cancel")))
          (when additional-message (format stream "~%~A~2% "additional-message)) ;; 2.1
	  (setf selection
	    (clim:accept `(member ,@(if extra-item 
                                        (cons extra-item kpml::*ex-sets*)
                                      kpml::*ex-sets*))
			 :stream stream
			 :view #-(and lispworks lispworks4.0) 'clim:list-pane-view
			       #+(and lispworks lispworks4.0) 'clim:radio-box-view
			 :prompt "Exercise set ....."
			 :default selection))
          #+lispworks (kpml-i::dialog-end-spacing)
	  (kpml-i-terpri stream))
      (abort () (return-from SELECT-AN-EXAMPLE-SET nil)))
    selection))

;;; ----------------------------------------------------------------------
;;; Extra generation commands...

(defmacro LAUNCH-SAYING-PROCESS (body)
  #+(or allegro lispworks lucid)
  `(let ((frame clim:*application-frame*))
    (setf *say-process*
      (cpc:make-process    ;; things complicated here in order to make sure
       #'(lambda ()        ;; that the right frame is current when this
	                   ;; thread runs...
	   (let ((clim:*application-frame* frame))  
	     ,body))
       :name "say")))
  #+(and aclpc acl3.0)     ;; here no complication because ACL3.0 is not
  body)                    ;; multithreaded.

(define-example-operations-frame-command 
    (com-SAY-EXAMPLE-EM :name "Say example" :menu nil)
  ((example-name 'example-name :gesture :menu))
  (launch-saying-process 
   (progn
     (run-say-top-level example-name)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

(define-example-operations-frame-command 
    (com-generate-sentence-em :name "Generate an example" :menu nil)
    ()
  (launch-saying-process 
   (progn
     (run-say-top-level)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

(define-example-operations-frame-command 
    (com-generate-again-em :name "Generate again" :menu nil)
    ()
  (launch-saying-process 
   (progn
     (run-say-again)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

(define-example-operations-frame-command
  (com-GENERATE-EXOP-NEXT :name "Generate next" :menu nil)
  ()
  (launch-saying-process 
   (progn
     (run-say-on-next-example)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))
    
(define-example-operations-frame-command 
  (com-GENERATE-EXOP-NEXT-MARKED :name "Generate next marked" :menu nil)
  ()
  (launch-saying-process
   (progn
     (run-say-on-next-marked-example)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

(define-example-operations-frame-command 
  (com-GENERATE-NEXT-UNGENERATED :name t :menu nil)
  ()
  (launch-saying-process
   (progn
     (run-say-on-next-ungenerated-example)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

(define-example-operations-frame-command 
  (com-GENERATE-NEXT-MISMATCHED :name t :menu nil)
  ()
  (launch-saying-process
   (progn
     (run-say-on-next-mismatched-example)
     (clim:redisplay-frame-pane
      clim:*application-frame* 'example-list :force-p nil))))

;;; ----------------------------------------------------------------------
;;; Pointers to commands defined elsewhere but which we don't have since
;;; we're not wanting to inherit the entire command tables involved...

(define-example-operations-frame-command 
    (com-load-example-files-em :name "Load example files" :menu nil)
    ()
    (com-load-example-files))

(define-example-operations-frame-command 
    (com-load-example-sets :name "Load example files" :menu nil)
    ()
  (kpml::load-examples kpml::curlan)
  (clim:redisplay-frame-pane 
   clim:*application-frame* 'example-list :force-p T))

(define-example-operations-frame-command 
    (com-write-example-files-em :name "Save example files" :menu nil)
    ()
  ;; 2.1 make sure that messages only get delivered to the development frame...
  (let ((*standard-output* 
         (or (clim::get-frame-pane *resource-development-frame* 'inspector)
             (clim::get-frame-pane *resource-manager-frame* 'inspector))))
    (com-write-example-files)))

(define-example-operations-frame-command 
    (com-environment-directories-em :name "Environment directories" :menu nil)
    ()
    (com-environment-directories))

;;; ----------------------------------------------------------------------
;;; 2.0.48
;;; clearing examples was still leaving entries around for generate
;;; sentence to pick up... Clearing commands corrected here.
;;; ----------------------------------------------------------------------

(define-example-operations-frame-command 
    (com-CLEAR-EXAMPLES-EM :name "Clear all examples" :menu nil)
    ()
  (with-slots (exlist marked-set) clim:*application-frame*
    (com-clear-examples)
    ;; 2.0.48
    (setf *currently-focused-examples* nil)
    (setf exlist nil)
    (setf marked-set nil)))

(define-example-operations-frame-command 
    (com-set-language-em :name "Set current language" :menu nil)
    ()
  (com-set-language)
  (setf *currently-focused-examples* nil)
  (clim:redisplay-frame-pane
      clim:*application-frame* 'example-list :force-p T)
  )

;; 2.1
(define-example-operations-frame-command 
    (com-set-gloss-language :name "Set current gloss language" :menu nil)
    ()
  (let ((desired-lg (menu-choose 
		     kpml::all_languages
		     :associated-window 
		     (clim:frame-top-level-sheet 
		      clim:*application-frame*)
		     :label "Select the gloss language")))
    (when desired-lg
      (setf kpml::*gloss-language* desired-lg))
    (setf *currently-focused-examples* nil)
    (clim:redisplay-frame-pane
     clim:*application-frame* 'example-list :force-p T)
    ))

(define-example-operations-frame-command 
    (com-GENERATION-DISPLAY-MODES-EM :name "Generation Modes" :menu nil)
    ()
    (com-generation-display-modes))

;;; ----------------------------------------------------------------------
;;; The option of editing an example from the example manager got
;;; missed out prior to 2.0.6...
;;; ----------------------------------------------------------------------

#+(and :kpml-level>= :kpml-l2)
(define-example-operations-frame-command 
    (com-EDIT-EXAMPLE-EM :name "Edit example" :menu nil)
    ((example-name 'example-name :gesture :menu))
  ;; 2.0.6
  (com-edit-example example-name))

(define-example-operations-frame-command 
    (com-START-MISMATCH-INSPECTOR :name t :menu nil)
    ()
  ;; 2.1
  (startup-example-mismatches-frame :reset nil :launching-frame clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; 2.1 extras for helping regression checks...
;;; ----------------------------------------------------------------------

(defun CHECKS-OK-AGAINST-STANDARD-P (comparison-ex-set)
  (with-slots 
      (exlist lg-restriction ex-set-shown markedfirst)
      clim:*application-frame*
    (unless exlist 
      (setf exlist
	    (example-selector :differences-mode nil
			      :ex-set-name ex-set-shown
			      :markedfirst? nil                ;; 4.1
			      :alpha? T
			      :restrict-by-lg lg-restriction
			      :display-mode :target)))
    (loop for e in exlist
          never 	    
          (multiple-value-bind 
              (string generation-status mismatch)
              (fetch-example-comparison-information e comparison-ex-set :standard)
            mismatch))))
            

(define-example-operations-frame-command 
    (com-COMPARE-EXSETS :name "Compare example set versions" :menu nil)
    ()
  (with-slots (ex-set-shown)
      clim:*application-frame*
    (let ((selection (select-an-example-set 
                      ex-set-shown nil 
                      (format nil "For comparison with set: ~A" ex-set-shown)
                      )))
      (when selection
        (if (checks-ok-against-standard-p selection)
            (clim:notify-user 
             clim:*application-frame*
             "The selected examples and the selected standard generate identically.")
          (startup-example-mismatches-frame 
           :reset nil :launching-frame clim:*application-frame*
           :comparison-set selection))))))

(define-example-operations-frame-command 
    (com-EXOP-PUNCTUATION-IN-MISMATCH :name t :menu nil)
    ()
  (setf kpml::*mismatch-with-punctuation* 
    (not kpml::*mismatch-with-punctuation*))
  (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t))

;; 2.0.47
(define-example-operations-frame-command 
    (com-EXOP-CASE-SENSITIVITY-IN-MISMATCH :name t :menu nil)
    ()
  (setf kpml::*mismatch-with-case* 
    (not kpml::*mismatch-with-case*))
  (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p t))

;;; ----------------------------------------------------------------------
;;; Example display utilities...
;;; 2.0 uses ml-access functions for example records.

(defun DISPLAY-STRING-OF-EXAMPLE 
  (example-name 
   &optional 
   (message "~%Generated strings for example: ~A")
   (str-2 (clim:get-frame-pane *resource-development-frame* 'inspector))
   (stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
  (let* ((struct (kpml::fetch-example-info example-name 'kpml::structure))
	 (kpml::*most-recent-example* example-name))
    (declare (special kpml::*most-recent-example*))
    (if struct
	(progn
	  (when message (format str-2 message example-name))
	  (loop for s in (if (consp struct) struct (list struct)) do 
		(kpml-i-terpri str-2)
		(mouseable-sentence-display s str-2))
	  (kpml-i-terpri str-2))
      (format stream "~%No stored structure for example: ~A" example-name))))


;;; ----------------------------------------------------------------------
;;; 2.1, July99, Bremen. Following changed to use a proper application
;;;      frame rather than simply an accepting values popup.
;;; ----------------------------------------------------------------------

(defun BRING-UP-A-LIST-OF-EXAMPLES (features)
  (when features
    (startup-generated-example-string-frame 
     (sort features #'string<)
     "Some examples using feature(s)")))

;;; ----------------------------------------------------------------------
;;; 3.0; Jan7
;;; for Jiri.
;;; ... an extension so that it is easy to make reports for a whole bunch
;;; of example sets at the same time.
;;; ----------------------------------------------------------------------

(defun REPORT-SUPERSET-REPORT-STATUS (sets directory frame)
  (clim:notify-user
   frame
   (format nil "~{~%~A~}"
           (kpml::indent-and-fill 
            (list "Writing reports for example sets: "
                  (format nil "~A" sets) "."
                  "Target directory: " (format nil "~S" directory) "."
                  ". This could take a while... A message will be given when done."
                  "Click OK to start."
                  )
            :right-margin-p T :right-margin 60))))

(defun REPORT-SUPERSET-REPORT-DONE (sets directory frame)
  (clim:notify-user
   frame
   (format nil "~{~%~A~}"
           (kpml::indent-and-fill 
            (list "Reports for example sets: "
                  (format nil "~A" sets) " done."
                  "Target directory is: " (format nil "~S" directory) "."
                  )
            :right-margin-p T :right-margin 60))))

  ;; ----------------------------------------------------------------------
  ;; 3.2.51 
  ;;  not really a bug, it was just unclear that the window was coming
  ;;  up with all example sets already selected and so we need to
  ;;  *de-select* only those that we don't need! Check the name
  ;;  when folding into 3.3 or later, as it was wrong...
  ;;  ("com-REPORT-EXAMPLE-SURPERSET")
  ;;
  ;; 3.2.68 folded in: better ordering in the index.
  ;; 4.0    Unicode option added (Lispworks).

(define-example-operations-frame-command 
    (com-REPORT-EXAMPLE-SUPERSET :name "Report set" :menu T)
    ()
  (with-slots (lg-restriction) clim:*application-frame*
    (kpml::actualize-list-of-example-sets-loaded lg-restriction)
    
    #+(and acl3.0 aclpc)
    (clim:notify-user
     clim:*application-frame*
     "Not available for ACL3.0 PC")

    #-(and acl3.0 aclpc)
    (let* ((possible-exsets kpml::*ex-sets*)
           (style :html)
           (with-spls? T)
           (marked-only? nil)
	   (in-unicode? nil)
           (report-root *default-kpml-hardcopy-directory*)
           (selected-exsets
            (let ((stream 
                   (clim::frame-top-level-sheet clim:*application-frame*))
                  (value possible-exsets))
              (clim:accepting-values
                  (stream :own-window T
                          :scroll-bars :horizontal
                          :width 800
                          :resynchronize-every-pass t
                          :label "Select example sets:")
                (clim:with-text-face (stream :bold)
                  (clim:with-text-size (stream :larger)
                    (format stream "~%General Report Tool.")))
                (format stream "~2%Select some subset of example sets for reporting")
                (format stream "~%and the style of report required.")
		;; 3.2.51
		(format stream "~% N.B. all example sets are selected by default!!!")
                (kpml-i-terpri stream)
                (kpml-i-terpri stream)
                (format stream "~%Select...")
                (setf value
		      (clim:accept `(clim:subset-sequence ,possible-exsets)
			           :stream stream
			           :view #-lispworks 'clim:list-pane-view 
                                   #+lispworks clim:+textual-dialog-view+
			           :prompt "Select"
			           :default value))
                (radio-box-accept style (:html :text) "Report style")
                (kpml-i-terpri stream)
		(on-or-off with-spls? "SPLs included")
                (kpml-i-terpri stream)
                (on-or-off marked-only? "Marked examples only")
#+lispworks	(kpml-i-terpri stream)
#+lispworks     (on-or-off in-unicode? "Unicode enforced")
                (kpml-i-terpri stream)
                (setf report-root
                      (clim:accept 'clim:pathname
			           :stream stream
                                   #+lispworks :view #+lispworks clim:+textual-dialog-view+
			           :prompt "Root of reports (MUST BE A NEW DIRECTORY!!!):"
			           :default report-root))
                #+lispworks (kpml-i::dialog-end-spacing)
                value))))
      (let ((*unicode-in-reports* in-unicode?))        ;; 4.0  -- Unicode --
	(declare (special *unicode-in-reports*))       ;;  make this trickle
	(make-report-superset                          ;;  down to the report
	 selected-exsets style with-SPLs? marked-only? ;;  functions as
	 (kpml::coerce-directory                       ;;  appropriate...
	  (kpml::create-a-directory 
	   (kpml::coerce-directory report-root))))))))
  
;;; ----------------------------------------------------------------------
;;; Following function runs through the example sets selected, and makes
;;; reports for each one according to the settings given...
;;;  for each example set: we run the example runner
;;;                        call an appropriate report maker
;;;  reports all land up in the root directory specified.
;;;
;;; 4.0 add some indication of success/failure rates to the report
;;; ----------------------------------------------------------------------

(defun MAKE-REPORT-SUPERSET 
  (selected-exsets style with-SPLs? marked-only? report-root)
  (with-slots (ex-set-shown exlist marked-set) clim:*application-frame*
    (report-superset-report-status selected-exsets report-root clim:*application-frame*)
    (let ((*default-kpml-hardcopy-directory* report-root)
          (exset-file-pairs nil)
	  (noe 0)
	  (fai nil)
	  (mismatch-count 0))
      (declare (special *default-kpml-hardcopy-directory*))
      (loop for selection in selected-exsets
            as file = (make-new-typed-filename (string selection)
		                               kpml::curlan 
                                               (if (eq style :html)
                                                   (if with-SPLs? "dir" "html")
                                                 "txt"))
            do
            ;; do a selection of the example set and update display...
	    (setf ex-set-shown selection)
	    (com-redisplay-example-list)
            
            ;; run the example runner...
	    (multiple-value-bind 
	     (number-of-examples failed)
	     (kpml::example-runner-to-file-only
	      (if marked-only? marked-set exlist)
	      (namestring
	       (merge-pathnames
		kpml::*example-runner-results*
		(pathname (kpml::make-example-results-filename))))
	      :say-p t)
	     (setf noe number-of-examples
		   fai failed))

            ;; make a report...
            (if (eq style :html)
		(multiple-value-bind              ;; 4.0
		    (file mc)
		    (make-an-html-mismatch-report 
		     (remove-if-not 
		      #'(lambda (e) (member e marked-set)) exlist)
		     T selection
		     :file file
		     :with-semantics-p with-SPLs?
		     :marked-only-p marked-only?)
		  (setf mismatch-count mc))
              (make-a-text-mismatch-report
               (remove-if-not #'(lambda (e) (member e marked-set)) exlist)
               T selection
               :file file
	       :with-semantics-p with-SPLs?
               :marked-only-p marked-only?))
              
            ;; record that we have done this and where we did it...
	    ;; 4.0 the pairs are no longer pairs!
            (push (list selection file noe fai mismatch-count)
		  exset-file-pairs))
      (when (eq style :html)
        (make-report-superset-index exset-file-pairs with-spls? report-root))
      (report-superset-report-done selected-exsets report-root clim:*application-frame*))))




(defun MAKE-REPORT-SUPERSET-INDEX 
    (exset-file-pairs with-spls? report-root
     &key (texty *texty-index-mode*))
  ;; 3.2.68 : made a bit prettier, better HTML, and more informative...
  ;; 4.0    : success rates added if there are failures...
  ;;          index set out as a table by default...
  (let ((report-pathname
         (merge-pathnames "index.html" report-root))
	(page-title
	 (format nil "Example sets generated for language ~A at ~A"
                kpml::curlan (kpml::time-stamp))))
    (when exset-file-pairs
      (with-open-file 
          (stream report-pathname :direction :output :if-exists :supersede)
	  (as-html 
	   (page-title)
	   (format stream "<H2>~A</H2>" page-title)
	   (kpml::present-language-description stream kpml::curlan)
	   (cond 
	    (texty
	     (format stream "<UL>")
	     (loop for (exset file noe fai mc) 
		 in (sort exset-file-pairs #'string< :key #'car)
		 do 
		   (format 
		    stream "~%<LI><A HREF=\"~A~A\">~A</A> (~A example~:P" 
		    file (if with-spls? "/index.html" "") exset noe)
		   (if (null mc) (setf mc 0))
		   (when (> mc 0)
		     (format stream "; ~A mismatch" mc))
		   (when fai
		     (format stream "; ~A hard failure~:P" (length fai)))
		   (format stream ")"))
	     (format stream "</UL>"))
	    (t
	     (format stream "~%<table>")
	     (format stream "~% <tr><td>Example set</td><td>Number of examples</td><td>Mismatches</td><td>Hard failures</td></tr>")
	     (loop for (exset file noe fai mc) 
		 in (sort exset-file-pairs #'string< :key #'car)
		 summing noe into excount
		 do 
		   (format 
		    stream "~% <tr><td><A HREF=\"~A~A\">~A</A></td><td>~A</td>" 
		    file (if with-spls? "/index.html" "") exset noe)
		   (if (null mc) (setf mc 0))
		   (if (> mc 0)
		       (format stream "<td>~A</td>" mc)
		     (format stream "<td>&nbsp;</td>" mc))
		   (if fai
		       (format stream "<td>~A</td>" (length fai))
		     (format stream "<td>&nbsp;</td>" mc))
		   (format stream "</tr>")
		 finally
		   (format stream "<tr><td/><td>~A</td></tr>" excount))
	     (format stream "~%</table>")
	     )))))))

;;; ----------------------------------------------------------------------
;;; 3.2.47 further menu options...
;;; ----------------------------------------------------------------------

(define-example-operations-frame-command 
  (com-toggle-check-dups :name t :menu nil)
  ()
  (setf kpml::*check-ex-dups-on-loading* 
	(not kpml::*check-ex-dups-on-loading*))
  (clim:notify-user
   clim:*application-frame*
   (if kpml::*check-ex-dups-on-loading* 
       "Duplicate example names will be checked."
     "Duplicate example names will NOT be checked.")))


(define-example-operations-frame-command 
  (com-SET-MAX-COMPLEXITY :name t :menu nil)
  ()
  (let ((max (if *exrun-complexity-maximum*
		 *exrun-complexity-maximum*
	       kpml::complexity-maximum))
	(stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (kpml-i::positioned-accepting-values
     (stream :own-window kpml-i::*own-window*
	     :x-position 40
	     :y-position 40
	     :resynchronize-every-pass t
	     :label "Set complexity maximum" 
	     :exit-boxes '((:exit "Set")(:abort "Cancel")))
     (kpml-i-terpri stream)
     (setf max
	   (clim:accept `clim:integer :stream stream
			:prompt "Maximum: "
			:default max)))
    (setf *exrun-complexity-maximum* max)))

;; 4.0 there were missing package specifications on the globals
;;     to do with reuse of SPL names in the following function. 
;;     Tut tut.

(define-example-operations-frame-command 
  (com-EXOP-SET-EX-NAMES :name t :menu nil)
  ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(name kpml::*default-created-spl-name*)
	(reuse kpml::*reuse-created-spls*))
    (kpml-i::positioned-accepting-values
     (stream :own-window kpml-i::*own-window*
	     :x-position 40
	     :y-position 40
	     :resynchronize-every-pass t
	     :label "Set example and example set name defaults" 
	     :exit-boxes '((:exit "Set")(:abort "Cancel")))
     (kpml-i-terpri stream)
     (setf name
	   (clim:accept `clim:string :stream stream
			:prompt "Default created SPL name: "
			:default name))
     (kpml-i-terpri stream)
     (setf reuse
	   (clim:accept `clim:boolean :stream stream
			:prompt "Reuse SPL names: "
			:default reuse)))
    (setf kpml::*default-created-spl-name* name
	  kpml::*reuse-created-spls* reuse)
    ))


;;; ----------------------------------------------------------------------
;;; 4.1
;;; Additions, July 2006, Bremen

(defun GET-A-SUBSTRING ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(selection "some string"))
    (restart-case
     (clim:accepting-values
      (stream :own-window T ; *wide-own-window*
	      :scroll-bars :horizontal
	      :resynchronize-every-pass t
	      #+lispworks :width #+lispworks 400
	      #+lispworks :height #+lispworks 200
	      :right-margin 200
	      :bottom-margin 50
	      :label "Substring search" 
	      :exit-boxes 
	      '((:exit "Click to search")(:abort "Click to cancel")))
      (setf selection
	    (clim:accept 
	     'clim:string :stream stream
	     #+lispworks :view #+lispworks clim:+textual-dialog-view+
	     :prompt "Substring"
	     :default selection))
      #+lispworks (kpml-i::dialog-end-spacing)
      (kpml-i-terpri stream))
     (abort () (return-from GET-A-SUBSTRING "")))
    selection))

(defun PULL-OUT-MARKED-EXAMPLES (exlist)
  (declare (special marked-set-holder))
  (loop for ex in exlist
	if (member ex marked-set-holder) collecting ex into marked
	else collecting ex into unmarked
	finally 
	(return (append marked unmarked))))