(in-package "KPML-I")

;;; File: example-mismatches.lisp
;;; John:Edinburgh:Oct98
;;; KPML 2.0.14
;;;      2.0.47 folded in.
;;;      2.1    glosses added.
;;;             comparison of example sets added.
;;;      4.0    enforced Unicode writing flag for reports added.

;;; An add-on to the example manager that makes it easier to look at
;;; the generated and the target forms of examples and to pick on these
;;; for improvement when there are mismatches, etc.

;;; ----------------------------------------------------------------------
;;; A couple of globals...
;;; ----------------------------------------------------------------------

(defvar *ex-mismatch-frame* nil "The example mismatch frame")

(defvar *ex-mismatch-fg* clim:+red+ "The foreground colour")
(defvar *ex-mismatch-bg* clim:+green+ "The background colour")
(defvar *ex-mismatching-is-fg* T
  "Allows user to select whether mismatching or matching is to be 
   considered the criteria for foregrounding")
(defvar *show-matches-at-all?* T "allows matches to be hidden")
(defvar *show-glosses-at-all?* nil "allows glosses to be shown")
(defvar *mismatch-changed* nil "marker for changed display")

(defvar kpml::*spl-slot-shadowing-for-text-reports*
  '(:gloss :set-name :generatedform :targetform :selectionexpressions :structure
    :preselections))

  ;; 3.2.37 this variety of report was missing. Added for completeness...
  ;;
(defvar *structures-in-reports* nil)

  ;; 4.0
(defvar *interlinears-in-reports* T)

  ;;  4.0 Unicode can be forced for reports, 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) 
  ;;
  ;; Actual Definition given in example operations.

;;; ----------------------------------------------------------------------
;;; Some command tables for making it all pretty... (colour-settings are
;;; provided by a macro for building commands put at the end of the
;;; file).
;;; ----------------------------------------------------------------------

  ;; ----------------------------------------------------------------------
  ;; 3.2.18 
  ;;            set the gloss language from the mismatch report
  ;;            window too.
  ;; ----------------------------------------------------------------------

(clim:define-command-table 
 EXMISM-HIGHLIGHTING-OPTIONS-COMMAND-TABLE
    :menu (("Toggle mismatch/match foregrounding" 
	    :command com-match-foregrounding)
	   ("Select foreground colour" :menu exmism-foreground-colour)
	   ("Select background colour" :menu exmism-background-colour)
	   ;; 3.2.18
	   ("Set current gloss language" :command com-set-gloss-language-2)
	   ("-----" :divider :line)
	   ("Toggle showing of matches" :command com-toggle-show-matches)
	   ("Toggle showing of glosses" :command com-toggle-show-glosses)
	   ))

(clim:define-command-table 
    EXMISM-FOREGROUND-COLOUR
    :menu (("Red" :command exmism-fg-red)
	   ("Green" :command exmism-fg-green)
	   ("Blue" :command exmism-fg-blue)
	   ("Black" :command exmism-fg-black)
	   ("Magenta" :command exmism-fg-magenta)
           ("Yellow" :command exmism-fg-yellow)
           ("Divider" :divider)
           ("Grey" :command exmism-fg-grey)
           ("Light grey" :command exmism-fg-light-grey)))


(clim:define-command-table 
    EXMISM-BACKGROUND-COLOUR
    :menu (("Red" :command exmism-bg-red)
	   ("Green" :command exmism-bg-green)
	   ("Blue" :command exmism-bg-blue)
	   ("Black" :command exmism-bg-black)
	   ("Magenta" :command exmism-bg-magenta)
           ("Yellow" :command exmism-bg-yellow)
           ("Divider" :divider)
           ("Grey" :command exmism-bg-grey)
           ("Light grey" :command exmism-bg-light-grey)))

;; 2.0.47+3.2.23+3.2.37
(clim:define-command-table 
 REPORT-OPTIONS-COMMAND-TABLE
    :menu (("Report only" :command com-make-mismatch-report)
	   ("SPLs included" :command com-make-mismatch-report-with-semantics)
	   ("Report of marked examples only" 
	    :command com-make-mismatch-report-marked-only)
	   ("Report of marked examples including spls"
	    :command com-MAKE-MISMATCH-REPORT-MARKED-WITH-SPLS)
           ("Straight text report" :command com-make-straight-report)
	   ("-----" :divider :line)
	   ("Structures included in reports" 
	    :command com-toggle-report-structure-inclusion-on)
	   ("Structures not included in reports" 
	    :command com-toggle-report-structure-inclusion-off)
	   ;; 4.0 Add Unicode writing options... these take precedence
	   ;;     over the font declaration in the property file for
	   ;;     a language.
	   #+lispworks
	   ("divider2" :divider :line)
	   #+lispworks
	   ("Reports created in Unicode" 
	    :command com-toggle-report-unicode-on)
	   #+lispworks
	   ("Reports not (necessarily) created in Unicode" 
	    :command com-toggle-report-unicode-off)
	   ("divider3" :divider :line)
	   ("Interlinear glosses and transliterations in report" 
	    :command com-interlinears-on)
	   ("Interlinear glosses and transliterations not in report" 
	    :command com-interlinears-off)
	   ))

;;; ----------------------------------------------------------------------
;;; The application frame...
;;; ----------------------------------------------------------------------

(clim:define-application-frame EXAMPLE-MISMATCHES-FRAME ()
  (
   (ex-set-shown :initform nil)          ;; currently focused exset
   (comparison-ex-set :initform nil)     ;; 2.1 comparison set
   (exlist :initform nil)
   (lg-restriction :initform T) 
   (launching-frame :initform nil)       ;; 2.1 where we get started from
   )
  (:menu-bar T)
  (:top-level (clim:default-frame-top-level))
  (:command-table 
   (example-mismatches-commands
    :menu
    (
     #-acl3.0
     ("Quit" :command com-quit-example-mismatch-list)
     ("Highlight" :menu  exmism-highlighting-options-command-table)
     ("Reports" :menu report-options-command-table)
     ("Redisplay" :command com-redisplay-example-mismatch-list)
     ;; 2.0.47
     )))
  (: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 :break
		 :end-of-page-action :allow
		 :initial-cursor-visibility :inactive
		 :display-function 'example-list-displayer
		 :text-style *sans-serif--bold--10*
		 :scroll-bars :both)
   (mouse-doc   :pointer-documentation
		:foreground  mouse-doc-fg
		:background  mouse-doc-bg))
  (:layouts (first 
	     (clim:vertically
		 ()
	       (:fill example-list)
	       (#+lispworks 1/4 #-lispworks 80 exset-list)
	       (2/32 mouse-doc)))))

;;; ----------------------------------------------------------------------
;;; A few presentation methods...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action PRESENT-EXSET-NAME
    (exset-name nil example-mismatches-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-mismatches-list)))

(clim:define-presentation-type MISMATCH ())

(clim:define-presentation-action PRESENT-MISMATCH
    (mismatch nil example-mismatches-commands
		:documentation "Accept this string as target")
  (object)
  (setf (kpml::fetch-example-info object 'kpml::targetform)
    (kpml::fetch-example-info object 'kpml::generatedform))
  (setf *mismatch-changed* (not *mismatch-changed*))
  (clim:redisplay-frame-pane 
     clim:*application-frame* 'example-list :force-p nil))


;;; ----------------------------------------------------------------------
;;; And a couple of commands...
;;; ----------------------------------------------------------------------

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

#-acl3.0
(define-example-mismatches-frame-command 
    (com-QUIT-EXAMPLE-MISMATCH-LIST :name "Quit" :menu T)
    ()
  (close-a-window clim:*application-frame*))


(define-example-mismatches-frame-command 
    (com-MAKE-STRAIGHT-REPORT  :name "Straight text report" :menu nil)
    ()
    (with-slots 
        (exlist lg-restriction ex-set-shown)
        clim:*application-frame*
      (let ((results
	     (make-a-text-mismatch-report
	      exlist lg-restriction ex-set-shown)))
        (report-mismatch-report-status results clim:*application-frame*))))

(define-example-mismatches-frame-command 
    (com-MAKE-MISMATCH-REPORT :name "Report only" :menu nil)
    ()
  (with-slots 
      (exlist lg-restriction ex-set-shown)
      clim:*application-frame*
    (let ((results
	   (make-an-html-mismatch-report
	    exlist lg-restriction ex-set-shown)))
      (report-mismatch-report-status results clim:*application-frame*))))

;;; 2.0.47 this command produces an entire directory structure with the
;;;        simple report as the index and SPLs for each of the examples
;;;        hyperlinked as separate files...
(define-example-mismatches-frame-command 
    (com-make-mismatch-report-with-semantics :name "SPLs included" :menu nil)
    ()
  (with-slots 
      (exlist lg-restriction ex-set-shown)
      clim:*application-frame*
    (let ((results
	   (make-an-html-mismatch-report
	    exlist lg-restriction ex-set-shown
	    :with-semantics-p T)))
      (report-mismatch-report-status results clim:*application-frame*))))

;;; 2.1 For Hana...
;;; 3.2.46 Was not sorting because the marked-set is not sorted by default.
(define-example-mismatches-frame-command 
    (com-MAKE-MISMATCH-REPORT-MARKED-ONLY 
     :name "Report of marked examples only" :menu nil)
    ()
  (with-slots (launching-frame lg-restriction ex-set-shown)
      clim:*application-frame*
    (with-slots (marked-set) launching-frame
     (let* ((maybe-sorted-set 
	     (if *list-examples-alphabetically*
		 (sort marked-set #'kpml::numbered-name-lessp)
	       marked-set))
            (results 
	     (make-an-html-mismatch-report
	      maybe-sorted-set lg-restriction ex-set-shown
	      :marked-only-p T)))
     (report-mismatch-report-status results clim:*application-frame*)))))

;;; ----------------------------------------------------------------------
;;; 2.1 keep the user informed of what is going on...
;;; ----------------------------------------------------------------------

(defun REPORT-MISMATCH-REPORT-STATUS (results frame)
  (if results
      (clim:notify-user
       frame
       (format nil "~{~%~A~}"
	       (kpml::indent-and-fill 
		(list "Example report completed. Written to: "
		      (format nil "~S" results))
		:right-margin-p T :right-margin 40)))
    (clim:notify-user frame "Failed to write example report.")))


(define-example-mismatches-frame-command 
    (com-MATCH-FOREGROUNDING :name "Match/Mismatch Foregrounding" :menu nil)
    ()
  (setf *ex-mismatching-is-fg* (not *ex-mismatching-is-fg*))
  (clim:redisplay-frame-pane 
    clim:*application-frame* 'example-list :force-p t))

(define-example-mismatches-frame-command 
    (com-TOGGLE-SHOW-MATCHES :name "Toggle showing of matches" :menu nil)
    ()
  (setf *show-matches-at-all?* (not *show-matches-at-all?*))
  (clim:redisplay-frame-pane 
    clim:*application-frame* 'example-list :force-p nil))

(define-example-mismatches-frame-command 
    (com-TOGGLE-SHOW-GLOSSES :name "Toggle showing of glosses" :menu nil)
    ()
  (setf *show-glosses-at-all?* (not *show-glosses-at-all?*))
  (clim:redisplay-frame-pane 
    clim:*application-frame* 'example-list :force-p T))

(define-example-mismatches-frame-command 
    (com-SAY-EXAMPLE-MISM :name "Say example" :menu nil)
  ((example-name 'example-name :gesture :select))
  (launch-saying-process 
   (progn
     (run-say-top-level example-name)
     (setf *mismatch-changed* (not *mismatch-changed*))
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p nil))))

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

(define-example-mismatches-frame-command 
    (com-EDIT-EXAMPLE-MISM :name "Edit example" :menu nil)
    ((example-name 'example-name :gesture :select))
  (com-edit-example example-name))

(define-example-mismatches-frame-command 
    (com-MARK-EXAMPLE-MISM :name "Mark example" :menu nil)
    ((example-name 'example-name :gesture :select))
  (with-slots (launching-frame) clim:*application-frame*
    (with-slots (marked-set) launching-frame
      (unless (member example-name marked-set)
	(push example-name marked-set)
	(setf *currently-marked* marked-set)))))

(define-example-mismatches-frame-command 
    (com-DELETE-EXAMPLE-MISM :name "Delete example" :menu nil)
    ((example-name 'example-name :gesture :select))
  (progn
    (push (cons example-name
		(kpml::fetch-example-info example-name 'kpml::everything))
	  *example-manager-deleted*)
    (kpml::delete-example example-name)))

;;; ----------------------------------------------------------------------
;;; The pane displayers for mismatches...
;;; ----------------------------------------------------------------------

(defmethod EXSET-LIST-DISPLAYER ((frame example-mismatches-frame) stream)
  ;; This is just the same at present as the method for example-operations
  ;; frames. Could just generalize the method but it might change later so...
  (clim:with-end-of-line-action (stream :wrap)
    (clim:updating-output 
	(stream :cache-value (sxhash kpml::*ex-sets*))
      (clim:with-text-face 
	  (stream '(:bold :italic))
	(format stream "~%~0TExample sets loaded..."))
      (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-mismatches-frame) stream)
  (with-slots 
      (exlist lg-restriction ex-set-shown comparison-ex-set)
      clim:*application-frame*
    (unless exlist 
      (setf exlist
	(example-selector :differences-mode nil
			  :ex-set-name ex-set-shown
			  :alpha? T
			  :restrict-by-lg lg-restriction
			  :display-mode :target)))
    (clim:stream-set-cursor-position stream 0 0)
    (clim:formatting-table 
	(stream :move-cursor nil)
      (clim:updating-output
	  (stream 
	   :cache-value 
	   (sxhash (list kpml::curlan ex-set-shown *mismatch-changed*)))
	(clim:formatting-row (stream)
	  (clim:with-text-style (stream *sans-serif--italic--8*)
	    (clim:formatting-cell (stream)
              (if comparison-ex-set 
                  (format stream " generated in: ~A " comparison-ex-set)
                (format stream "    target")))
	     (clim:formatting-cell (stream)
	      (format stream "   "))
	    (clim:formatting-cell (stream)
	      (format stream "    generated"))
	    (clim:formatting-cell (stream)
	      (format stream "    name"))
	    )))
      (setf *focused-exercise-set* ex-set-shown)
      (setf *currently-focused-examples* exlist)
      (loop for e in exlist
	  when (kpml::example-p e)
	  do 
	    (multiple-value-bind 
		(string generation-status mismatch)
                (if comparison-ex-set
                    (fetch-example-comparison-information e comparison-ex-set :standard)
		  (fetch-example-information e :target nil))
	      (declare (ignore generation-status))
	      (multiple-value-bind 
		  (string2 generation-status2 mismatch2)
                  (if comparison-ex-set
                      (fetch-example-comparison-information e comparison-ex-set :comparison)
		    (fetch-example-information e :generated nil))
		(declare (ignore mismatch2 generation-status2))
		(when (or *show-matches-at-all?* mismatch)
		  (clim:formatting-row (stream)
		    (clim:updating-output
			(stream :cache-value (list string string2)
				:cache-test #'equal)
		     (macrolet 
			 ((print-it ()
			    '(with-conditional-font-changes-for-language 
			      (stream kpml::curlan)
			      (clim:updating-output
				  (stream :cache-value string 
				   :cache-test #'string=)
				(clim:formatting-cell (stream)
				  (clim:filling-output
				      (stream 
				       :fill-width 
				       `(,*example-menu-width* :character))
				    (format stream "~A" string)
				    (when *show-glosses-at-all?*
				      (show-gloss e stream))
				    )))
			      (clim:formatting-cell (stream)
				(clim:with-drawing-options
				    (stream :ink clim:+black+)
				  (format stream " : ")))
			      (clim:updating-output
				  (stream :cache-value string2 
				   :cache-test #'string=)
				(clim:formatting-cell (stream)
				  (clim:filling-output
				      (stream 
				       :fill-width 
				       `(,*example-menu-width* :character))
				    (if mismatch
					(clim:with-output-as-presentation
					    (stream e 'mismatch)
					  (format stream "~A" string2))
				      (format stream "~A" string2))))))))
		       (if (string= string2 kpml::*failure-string*)
			   (clim:with-drawing-options
			       (stream :ink *grey*) (print-it))
			 (if *ex-mismatching-is-fg*
			     (if mismatch
				 (clim:with-text-face 
				     (stream '(:bold :italic))
				   (clim:with-drawing-options 
				       (stream :ink *ex-mismatch-fg*)
				     (print-it)))
			       (clim:with-drawing-options
				   (stream :ink *ex-mismatch-bg*)
				 (print-it)))
			   (if mismatch 
			       (clim:with-drawing-options
				   (stream :ink *ex-mismatch-bg*)
				 (print-it))
			     (clim:with-text-face 
				 (stream '(:bold :italic))
			       (clim:with-drawing-options 
				   (stream :ink *ex-mismatch-fg*)
				 (print-it)))))))
		     (clim:formatting-cell (stream)
		       (clim:with-text-style (stream *sans-serif--bold--7*)
			 (clim:with-output-as-presentation 
                              (stream e 'example-name)
			   (format stream "~A" e))))))
		   )))))
    (format stream "~%~0T")))


;;; ----------------------------------------------------------------------
;;; Startup function
;;; ----------------------------------------------------------------------

(define-kpml-i-frame-starter 
 STARTUP-EXAMPLE-MISMATCHES-FRAME-INTERNAL
 example-mismatches-frame
 "KPML EXAMPLE MISMATCHES TOOL"
 *ex-mismatch-frame*
 :layout (:pretty-name (if comparison-set
                           "Comparison of generated examples (KPML)"
                         "Mismatches in Target/Generated Examples (KPML)")
          :left 100 :top 20
          :width #-acl3.0 500 #+acl3.0 800 :height 400)
 :args (comparison-set launching-frame)
 :frameinits ((launching-frame . launching-frame)
	      (ex-set-shown . *focused-exercise-set*)
              (comparison-ex-set .  comparison-set)))


(defun STARTUP-EXAMPLE-MISMATCHES-FRAME 
       (&key (reset nil)(launching-frame nil)(comparison-set nil))
  (let ((label
         (if comparison-set
             "Comparison of generated examples (KPML)"
           "Mismatches in Target/Generated Examples (KPML)")))
    (startup-example-mismatches-frame-internal comparison-set launching-frame :reset reset)))

;;; ----------------------------------------------------------------------
;;; The colour setting commands and colour management...
;;; ----------------------------------------------------------------------

(defmacro MISMATCH-COLOR-SETTER (com-label color clim-color fg?)
  `(define-example-mismatches-frame-command 
       (,(intern (format nil "EXMISM-~A-~A" (if fg? :fg :bg) color)
		 "KPML-I")
	:name ,com-label :menu nil)
       ()
     (setf ,(intern (format nil "*EX-MISMATCH-~A*" (if fg? :fg :bg)) "KPML-I")
       ,clim-color)
     (clim:redisplay-frame-pane 
      clim:*application-frame* 'example-list :force-p t)))

(defmacro DEFINE-MISMATCH-COLOR-COMMANDS ()
  `(progn
     ,@(loop for fg in '(T nil)
	   append
	 (loop for (color label clim-color)
	     in *kpml-colour-wheel*
	     collect
             `(mismatch-color-setter ,color ,label ,clim-color ,fg)))))

(define-mismatch-color-commands)

(defvar *clim-html-colors-alist* 
  `((,clim:+red+      "#CC0000")
    (,clim:+blue+     "#3366FF")
    (,clim:+green+    "#009900")
    (,clim:+black+    "#000000")
    (,clim:+magenta+  "#CC33CC")
    (,clim:+yellow+   "#FFFF00")
    (,*grey*          "#999999")))

(defun CLIM-COLOR-2-HTML-COLOR (clim-color)
  (let ((color (second (assoc clim-color *clim-html-colors-alist*))))
    (if color color (second (assoc clim:+black+ *clim-html-colors-alist*)))))

;;; ----------------------------------------------------------------------
;;; Can produce an HTML report/record of the state of the generated 
;;; examples and their mismatch status. Useful as part of ongoing 
;;; documentation. Modelled on the HTML region report function in 
;;; management/regions.lisp
;;;
;;; 2.1    allows presentation of marked examples only.
;;; 3.2.21 added font and character set support more properly.
;;; 4.0    return a count of the mismatches
;;;        and the example set description string if exists
;;; ---------------------------------------------------------

(defun MAKE-AN-HTML-MISMATCH-REPORT 
    (exlist lg-restriction ex-set-shown 
     &key (file nil)
	  (with-semantics-p nil)
	  (marked-only-p nil))
  (macrolet 
      (
       (TARGET-GENERATED-NAME-ROW ()
	 `(format stream "~%  <TR><TD><B><FONT COLOR=\"#993366\">TARGET</FONT></B></TD><TD><B><FONT COLOR=\"#993366\">GENERATED</FONT></B></TD><TD><B><FONT COLOR=\"#993366\">NAME</FONT></B></TD></TR>"))

       ;; followings make sure things balance...
       (AS-TABLE ((cols size) &body body)
	 (let 
	   ((start-table-def 
	     "~%<CENTER><TABLE BORDER COLS=~A WIDTH=~S BGCOLOR=\"#FFFFCC\">"))
	   `(progn
	      (format stream ,start-table-def ,cols ,size)
	      ,@body
	      (format stream "~%</TABLE></CENTER>"))))

       (ELEMENT ((&optional (color 'clim:+black+)) &body body)
	 `(progn 
	    (format stream "~%<TD><FONT COLOR=~S>" 
		    (clim-color-2-html-color ,color))
	    ,@body 
	    (format stream "~%</FONT></TD>")))

       (IN-COLOR ((&optional (color 'clim:+black+)) &body body)
	 `(progn 
	    (format stream "<FONT COLOR=~S>" 
		    (clim-color-2-html-color ,color))
	    ,@body 
	    (format stream "</FONT>")))
       
       (SMALLER (&body body)
	 `(progn (format stream "<FONT SIZE=-2>")
		 ,@body
		 (format stream "</FONT>")))

       (ROW (&body body)
	 `(progn (format stream "~%<TR VALIGN=TOP>") 
		 ,@body (format stream "~%</TR>")))

       (HTML-EXAMPLE-MISMATCH-REPORT-TITLE (header)
          `(format stream 
		   "~%<CENTER><TABLE BORDER COLS=1 WIDTH=\"100%\" BGCOLOR=\"#99FF99\"><TR><TD><B><FONT COLOR=\"#993366\" SIZE=+1> ~A </FONT></B></TD></TR></TABLE></CENTER>~%&nbsp;" ,header))
       )

    (unless file (setf file
		   (make-new-typed-filename 
		    (concatenate 'string
		      (if ex-set-shown (string ex-set-shown) "")
		      "-mismatches")
		    kpml::curlan (if with-semantics-p "dir" "html"))))

    ;; 2.0.47 if we want the semantics, we rebind 
    ;;        *default-kpml-hardcopy-directory* to a newly created
    ;;        subdirectory that all the SPLs are also placed in.
    ;;        The example list then goes in the index for that directory.
    ;; 
    ;; 2.1 returns the file that was created for use in 
    ;;     a notification to say that we are done when used from the
    ;;     interface...
    ;;
    (let* ((kpml::*demo-mode* nil)                ;; 3.2.46
	   (mismatch-count 0)
	   (*default-kpml-hardcopy-directory*
	    (if with-semantics-p 
		(kpml::coerce-directory
		 (kpml::create-a-directory 
		  (merge-pathnames file *default-kpml-hardcopy-directory*)))
	      *default-kpml-hardcopy-directory*))
	    (report-pathname
	     (merge-pathnames (if with-semantics-p "index.html" file) 
			      *default-kpml-hardcopy-directory*))
	    (page-title
	     (format nil "Example set (~A) generated for language ~A at ~A"
		     (if ex-set-shown
			 ex-set-shown
		       (if marked-only-p 
			   "selected examples only"
			 "all currently loaded"))
		     kpml::curlan (kpml::time-stamp))))
      (declare (special *default-kpml-hardcopy-directory* kpml::*demo-mode*))
      (with-open-file 
       (stream report-pathname :direction :output :if-exists :supersede
	       #+lispworks
	       :external-format  		         ;; 3.2.21/3.2.60
	       #+lispworks                       
	       (if *unicode-in-reports* :unicode         ;; 4.0
		 (kpml::file-encoding kpml::curlan)))
       (unicode-stamp)                                   ;; 4.0
       (unless exlist 
	 (setf exlist
	       (example-selector :differences-mode nil
				   :ex-set-name ex-set-shown
				   :alpha? T
				   :restrict-by-lg lg-restriction
				   :display-mode :target)))

       (as-html (page-title)  ;; 3.2.19
		(html-example-mismatch-report-title page-title)
		;; 3.2.23 + 4.0 example set descriptions too...
		(unless (and ex-set-shown 
			     (not marked-only-p)
			     (kpml::present-example-set-description
			      stream kpml::curlan ex-set-shown))
		  (kpml::present-language-description stream kpml::curlan))
	   ;; 2.0.24
	   (format
	    stream "~%<P>~A Examples in this selection." (length exlist))
	   (unless *show-matches-at-all?*
	     (format stream "~%<BR> <I>Only mismatches are shown.</I>"))
	   (when with-semantics-p 
	     (format stream "~%<BR>Click on example names for semantics."))
	   (when *structures-in-reports*
	     (format stream "~%<BR>Generated structures included."))
	   (in-color () (format stream "~%<P><P><B><U>Color Key</B></U>"))
	
	   (format stream "<UL>")
	   (when *show-matches-at-all?*
	     (in-color (*ex-mismatch-bg*) 
		       (format stream 
			       "<LI>Generated form matches the target</LI>")))
	   (in-color 
	    (*ex-mismatch-fg*) 
	    (format 
	     stream "<LI>Generated form does not match the target</LI>"))
	   (in-color 
	    (*grey*) 
	    (format 
	     stream "<LI>Failed to generate without user interaction</LI>"))
	   (format stream "</UL><P><P>")

	   (as-table 
	    (3 "95%")
	    (target-generated-name-row)
	    (setf *focused-exercise-set* ex-set-shown)
	    (setf *currently-focused-examples* exlist)
	    (loop for e in exlist
		  when (kpml::example-p e)
		  do 
		  (multiple-value-bind 
		      (string generation-status mismatch)
		      (fetch-example-information e :target nil)
		    (declare (ignore generation-status))
		    (multiple-value-bind 
			(string2 generation-status2 mismatch2)
			(fetch-example-information e :generated nil)
		      (declare (ignore mismatch2 generation-status2))
		   (progn
		     ;; 4.0  add mismatch count..
		     (when mismatch (setf mismatch-count (1+ mismatch-count)))
		     (when (or *show-matches-at-all?* mismatch)
		       (row
			(with-conditional-font-changes-for-language 
			    (stream kpml::curlan)
			  (let ((color 
				 (if (string= string2 kpml::*failure-string*)
				     *grey*
				   (if mismatch 
				       *ex-mismatch-fg* *ex-mismatch-bg*))))
			    (element (color) 
				     (format stream "~A" string)
				     ;; 2.1 glosses added...
				     ;; 3.2.24 gloss not shown properly...
				     (when *show-glosses-at-all?*
				       (let ((g (kpml::fetch-example-info 
						 e 'kpml::gloss)))
					 (when g
					   (smaller 
					    (format stream "<BR>~%(~A)" g)
					    )))))
			    (element (color) (format stream "~A" string2))
			    (element 
			     () 
			     ;; 2.0.24
			     (format stream 
				     (if mismatch "<B><I>~A</I></B>" "~A")
				     (if with-semantics-p
					 (make-file-and-href-for-semantics e)
				       e))))))))))))))
      ;; 4.0 add the mismatch count to the return values in 
      ;;     a caller wishes to use them...
      (values report-pathname mismatch-count))))


(defun MAKE-FILE-AND-HREF-FOR-SEMANTICS (example)
  (declare (special *default-kpml-hardcopy-directory*))
  (let ((path 
	 ;; 3.2.62 -- merge-pathnames doesn't do the desired thing
	 ;;           with example names with periods in them!
	 (pathname 
	  (concatenate 'string 
		       (string *default-kpml-hardcopy-directory*) 
		       (string example) ".html")))
	(title (format nil "Semantic specification for example: ~A" example)))
    (with-open-file 
	(stream path :direction :output :if-exists :supersede
		#+lispworks
	       :external-format  		 ;; 3.2.21 / 3.2.60
	       #+lispworks
	       (if *unicode-in-reports* :unicode         ;; 4.0
		 (kpml::file-encoding kpml::curlan)))
	(unicode-stamp)
      (as-html (title) ;; 3.2.19
       (format stream "<P><font size=+2><B>~A</B></font><p>" example)
       ;; 4.0       
       (when (and *interlinears-in-reports*
		  (kpml::fetch-example-info example 'kpml::structure))
	 (kpml::pprint-interlinear example stream :html kpml::curlan))

       (format stream "<P><PRE>")
       (let ((*standard-output* stream)
	     (kpml::*shadowed-slots* 
	      ;; 2.1 parameterized...
	      kpml::*spl-slot-shadowing-for-html-reports*))
	 (declare (special kpml::*shadowed-slots*))
	 (kpml::print-example example)
	 )
       (format stream "</PRE>")
       (when (kpml::fetch-example-info example 'kpml::comments)
	 (format stream "<P><HR><p><font size=+1><B>Comments:</B></font><blockquote>")
	 (format stream "~A"  (kpml::fetch-example-info example 'kpml::comments))
	 (format stream "</blockquote><P>"))
       (when (and *structures-in-reports*
		  (kpml::fetch-example-info example 'kpml::structure))
	 (format stream "<P><HR><p><font size=+1><B>Structure:</B></font><pre>")
	 (format stream "<A NAME=\"struct\">")
	 ;; 3.2.37
	 (kpml::pprint-example-structures example stream)
	 (format stream "<P><HR>"))       
       (format stream "<P><font size=-1><I><A HREF=\"index.html\">Return to index.</A></I></font>")
       )
      (if *structures-in-reports*
	  (format 
	   nil 
	   "<A HREF=\"~A.html\">~A</A><P><A HREF=\"~A.html#struct\"><font size=-2>structure</font></A>" 
	   (string example) example (string example))
	(format nil "<A HREF=\"~A.html\">~A</A>" (string example) example)))))

;;; ----------------------------------------------------------------------
;;; Straight text version of the report for handouts, etc.
;;; ----------------------------------------------------------------------

(defun MAKE-A-TEXT-MISMATCH-REPORT
       (exlist lg-restriction ex-set-shown 
               &key 
               (file nil)
	       (with-semantics-p T)
	       (marked-only-p nil))
  (unless file (setf file
		     (make-new-typed-filename 
		      (concatenate 'string
		                   (if ex-set-shown (string ex-set-shown) "")
		                   "-text-mismatches")
		      kpml::curlan  "txt")))

    ;; 2.1 returns the file that was created for use in 
    ;;     a notification to say that we are done when used from the
    ;;     interface...
    ;;
    (let* ((report-pathname
            (merge-pathnames file *default-kpml-hardcopy-directory*)))
      (with-open-file 
	  (stream report-pathname :direction :output :if-exists :supersede
		  #+lispworks
		  :external-format  		 ;; 3.2.21 / 3.2.60
		  #+lispworks
		  (if *unicode-in-reports* :unicode         ;; 4.0
		    (kpml::file-encoding kpml::curlan)))
	  (unicode-stamp)
	(unless exlist 
	  (setf exlist
	        (example-selector :differences-mode nil
			          :ex-set-name ex-set-shown
			          :alpha? T
			          :restrict-by-lg lg-restriction
			          :display-mode :target)))

        (format stream "Example set (~A) generated for language ~A at ~A"
                (if ex-set-shown
                    ex-set-shown
                  (if marked-only-p 
                      "marked examples only"
                    "all currently loaded"))
                kpml::curlan (kpml::time-stamp))
      
	;; 2.0.24
	(format stream "~%~A Examples in this selection." (length exlist))
	(unless *show-matches-at-all?*
	  (format stream "~%Only mismatches are shown."))
        (format stream "~2%")
        (setf *focused-exercise-set* ex-set-shown)
        (setf *currently-focused-examples* exlist)
        (loop for e in exlist
	      when (kpml::example-p e)
	      do 
              (multiple-value-bind 
                  (string generation-status mismatch)
                  (fetch-example-information e :target nil)
                (declare (ignore generation-status))
                (multiple-value-bind 
                    (string2 generation-status2 mismatch2)
                    (fetch-example-information e :generated nil)
                  (declare (ignore mismatch2 generation-status2))
                  (format stream "~2% ")
                  (with-conditional-font-changes-for-language 
                   (stream kpml::curlan)
                   (format stream "~%Name:      ~A    ~A" 
			   e (if mismatch "(mismatch)" ""))
                   (format stream "~%Target:    ~A" string)
                   (format stream "~%Generated: ~A" string2)
                   (let ((*standard-output* stream)
                         (kpml::*shadowed-slots* 
                          ;; 2.1 parameterized...
	                  kpml::*spl-slot-shadowing-for-text-reports*))
                     (declare (special kpml::*shadowed-slots*))
                     (kpml::print-example e))
		   ;; 3.2.37
		   (when *structures-in-reports*
		     (format stream "~2% ")
		     (kpml::pprint-example-structures e stream)))))))
        report-pathname))


(define-example-mismatches-frame-command 
  (com-SET-GLOSS-LANGUAGE-2 :name "Set current gloss language" :menu nil)
  ()
  (with-slots (exlist)
       clim:*application-frame*
       (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))
	 (clim:redisplay-frame-pane 
	  clim:*application-frame* 'example-list :force-p t))))


  ;; 3.2.23 this variety of report was missing. Added for completeness...
  ;; 3.2.46 sorting of marked examples set added as this is not by
  ;;        default the case...
  ;; 3.2.56 keyword in this function was missing its colon...
(define-example-mismatches-frame-command 
  (com-MAKE-MISMATCH-REPORT-MARKED-WITH-SPLS
   :name "Report of marked examples including spls" :menu nil)
  ()
  (with-slots (launching-frame lg-restriction ex-set-shown)
      clim:*application-frame*
    (with-slots (marked-set) launching-frame
     (let* ((maybe-sorted-set 
	     (if *list-examples-alphabetically*
		 (sort marked-set #'kpml::numbered-name-lessp)
	       marked-set))
            (results 
	     (make-an-html-mismatch-report
	      maybe-sorted-set lg-restriction ex-set-shown
	      :with-semantics-p T
	      :marked-only-p T)))
       (report-mismatch-report-status results clim:*application-frame*)))))

  ;; 3.2.37 this variety of report was missing. Added for completeness...
  ;;
(define-example-mismatches-frame-command 
  (com-TOGGLE-REPORT-STRUCTURE-INCLUSION-ON
   :name "Structures included in reports" :menu nil)
  ()
  (setf *structures-in-reports* T))

(define-example-mismatches-frame-command 
  (com-TOGGLE-REPORT-STRUCTURE-INCLUSION-OFF
   :name "Structures not included in reports" :menu nil)
  ()
  (setf *structures-in-reports* nil))

  ;; 4.0 Unicode toggling added...
(define-example-mismatches-frame-command 
  (COM-TOGGLE-REPORT-UNICODE-ON
   :name "Reports created in Unicode" :menu nil)
  ()
  (setf *unicode-in-reports* T))

(define-example-mismatches-frame-command 
  (COM-TOGGLE-REPORT-UNICODE-OFF
   :name "Reports not (necessarily) created in Unicode" :menu nil)
  ()
  (setf *unicode-in-reports* nil))

  ;; 4.0 interlinear glosses added...
(define-example-mismatches-frame-command 
  (com-INTERLINEARS-ON
   :name "Interlinear glosses and transliterations in report" :menu nil)
  ()
  (setf *interlinears-in-reports* T))

(define-example-mismatches-frame-command 
  (com-INTERLINEARS-OFF
   :name "Interlinear glosses and transliterations not in report" :menu nil)
  ()
  (setf *interlinears-in-reports* nil))
