(in-package "KPML-I")
;;;
;;; File: cumulative-history-display.lisp
;;; Author: John Bateman
;;; Created: 20 Feb 96
;;;
;;; New-style cumulative generation history window...
;;; Outputs an inspectable overview of the system and inquiry
;;; activity for a pass through the grammar... (or up to whatever
;;; point has been reached when activated).
;;; 
;;; Relies on KPML 0.9 patches in individual functions
;;; below constituent0 for
;;; making sure the relevant information is squirreled away
;;; to some instantiation of gh-table. Everything is inspectable
;;; in the normal way, with results surfacing in the inspection
;;; window.

;;; ----------------------------------------------------------------------
;;; 2.1 some extra filters and color codings...
;;; ----------------------------------------------------------------------

(defvar *show-cumulative-history-inquiry-sources* T)
(defvar *show-cumulative-history-inquiry-sources-explicitly* T)
(defvar *filter-history-display-by-source* nil)
(defvar *possible-inquiry-answer-sources* 
  '(kpml::spl-keyword
    kpml::constant-default
    kpml::operator-code
    kpml::default-value))

;;; ----------------------------------------------------------------------
;;; Window behavior improvement...
;;; 0.9.3
;;; ----------------------------------------------------------------------

(clim:define-application-frame CUMULATIVE-GH-FRAME ()
  ()
  (:menu-bar T)
  (:top-level (clim:default-frame-top-level))
  (:command-table 
   (cumulative-history-commands                  ;; 2.1 name was wrong!
    :inherit-from (kpml-resource-inspector)))
  (:panes 
   (history :application
	    ;; 0.9.2 
	    :incremental-redisplay T
	    :display-function 'cumulative-gh-display
	    :text-style *fix--bold--10*)
   (inquiry-gloss      :application
		       :scroll-bars :vertical
		       :foreground inquiry-fg
		       :background inquiry-bg
		       :text-style *fix--bold--12*)
   (mouse-doc   :pointer-documentation
		:foreground  mouse-doc-fg
		:background  mouse-doc-bg))
  (:layouts (first 
	     (clim:vertically
		 ()
	       (:fill history)
	       (3/32 inquiry-gloss)
	       #-lispworks mouse-doc))))

(define-cumulative-gh-frame-command 
    (com-REDISPLAY-HISTORY :name t :menu "Redisplay")
    ()
  (clim:window-clear 
   (clim:get-frame-pane clim:*application-frame* 'history :errorp NIL))
  (clim:redisplay-frame-pane clim:*application-frame* 'history :force-p t))

(defun REDISPLAY-HISTORY-IF-NECESSARY ()
  (when (and kpml::*gh-table* *cumulative-gh-frame*)
    (clim:redisplay-frame-pane *cumulative-gh-frame* 'history)))

(define-cumulative-gh-frame-command 
    (com-CLEAR-HISTORY :name t :menu "Clear history")
    ()
  (kpml::reset-generation-history))

(define-cumulative-gh-frame-command 
    (com-HISTORY-DISPLAY-OPTIONS :name t :menu "Display options")
    ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*)))
    (declare (special *called-from-chooser-display*))
    (clim:accepting-values
	(stream :own-window t :resynchronize-every-pass t
		:scroll-bars :vertical
		:label "History Display Options" :exit-boxes 
		'((:exit "Click here to use these values")
		  (:abort "Abandon selection")))
      (setq *cumulative-display-flags*
	    #-(and acl3.0 aclpc)
	    (clim:accept 
	     `(clim:subset-sequence ,*cumulative-display-flag-options*)
	     :stream stream
	     :view #-lispworks4.0 '(clim:list-pane-view :orientation :vertical)
                  #+lispworks4.0 clim:+textual-dialog-view+
	          :prompt "History display modes  ......"
	          :default *cumulative-display-flags*)
	    #+(and acl3.0 aclpc)
	    (kpml::get-a-subset-from 
	     *cumulative-display-flag-options*
	     *cumulative-display-flags*
	     "History display modes  ......")
	    )
      (kpml::kpml-i-terpri stream)                            ;; 2.1
      (kpml::kpml-i-terpri stream)
      (setf *show-cumulative-history-inquiry-sources*
	    (clim:accept '(member t nil) :stream stream
		     :prompt "Indicate inquiry sources by color..."
		     :default *show-cumulative-history-inquiry-sources*))
      (kpml::kpml-i-terpri stream)
      (setf *show-cumulative-history-inquiry-sources-explicitly*
	    (clim:accept '(member t nil) :stream stream
		     :prompt "Indicate inquiry sources by name..."
		     :default *show-cumulative-history-inquiry-sources-explicitly*))
      (kpml::kpml-i-terpri stream)
      (setq *filter-history-display-by-source*
	    #-(and acl3.0 aclpc)
	    (clim:accept 
	     `(clim:subset-sequence ,*possible-inquiry-answer-sources*)
	     :stream stream
	     :view #-lispworks '(clim:list-pane-view :orientation :horizontal)
             #+lispworks clim:+textual-dialog-view+
	     :prompt "Filter by inquiry result source ......"
	     :default *filter-history-display-by-source*)
	    #+(and acl3.0 aclpc)
	    (kpml::get-a-subset-from 
             *possible-inquiry-answer-sources*
             *cumulative-display-flags*
	     "Filter by inquiry result source ......")
	    )
      (kpml-i-terpri stream)
      #+lispworks (kpml-i::dialog-end-spacing))
    (unless *called-from-chooser-display*
      (clim:redisplay-frame-pane 
       clim:*application-frame* 'history :force-p t))
    ))

(define-cumulative-gh-frame-command 
    (com-RECORD-HISTORY :name t :menu "Make hardcopy of history")
    ()
  (cumulative-gh-hardrecord))

(define-cumulative-gh-frame-command 
    (com-QUIT-HISTORY :name t :menu "Quit")
    ()
  (setf *cumulative-gh-frame* nil)
  (close-a-window clim:*application-frame*))
  

;;; ----------------------------------------------------------------------
;;; 2.1 make the answer source visible by color coding if required...
;;; ----------------------------------------------------------------------

(defun COLOR-SELECTION-FOR-INQUIRY-SOURCE (source)
  (get-color
   (if *show-cumulative-history-inquiry-sources*
       (case source
         (kpml::spl-keyword 'green)
         (kpml::constant-default 'grey)
         (kpml::operator-code 'red)
         (kpml::default-value 'blue)
         (otherwise
          (if (equal source '(kpml::spl-keyword kpml::operator-code))
              'magenta
            'cyan ;; (list source 'merged-with-default)
            )))
     'black)))

;;; ----------------------------------------------------------------------
;;; 2.1 allow filtering of inquiry responses according to answer source...
;;; ----------------------------------------------------------------------

(defun HISTORY-DISPLAY-FOR-INQUIRY-SOURCE-P (source)
  (or (not *filter-history-display-by-source*)
      (member source *filter-history-display-by-source* :test #'equal)))

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

(defmethod CUMULATIVE-GH-DISPLAY ((frame cumulative-gh-frame) stream)
  (macrolet ((present-paras ()
               '(progn
                  (format stream "(")
                  (loop for i2 in (second i)
                        when (member :formal-parameters *cumulative-display-flags*)
                        do (format stream "~A" (car i2))
                        when (member :hubs *cumulative-display-flags*)
                        do (clim:with-output-as-presentation
                               (stream (cdr i2) 'spl-term)
                             (format stream "[~A]  "  (if (member :id *cumulative-display-flags*)
                                                          (cdr i2)
                                                        (symbol-if-term (cdr i2))))))
                  (format stream ")")))
             (present-response ()
                '(clim:with-output-as-presentation (stream (third i) 'spl-term)
                   (format stream  " = ~A" (if (member :id *cumulative-display-flags*)
                                               (third i)
                                             (symbol-if-term (third i)))))))
    (unless kpml::*gh-table*
      (clim:with-text-style (stream *sans-serif--roman--12*)
        (format stream "~2%No Information Accumulated....~3%")
        (return-from cumulative-gh-display nil)))
    (kpml::finalize-pending-entries)
    (loop for r in kpml::*gh-table*
          do 
	  (let ((system (kpml::gh-history-system r))
	        (feat   (kpml::gh-history-feature r)))
          ;; 2.1 allow filtering...
          (when (and (kpml::gh-history-inquiries r)
                     (loop for i in (kpml::gh-history-inquiries r)
                           thereis (history-display-for-inquiry-source-p (fourth i))))
            (format stream "~%~0T")
            (clim:with-text-size (stream :larger)
              (clim:with-output-as-presentation (stream system 'system)
                (format stream "~A:" system))
              (clim:with-output-as-presentation (stream feat 'feature)
                (format stream " ~(~A~) " feat)))
            (kpml-i-terpri stream)
            
            (format stream "~10T")
            (when (kpml::gh-history-inquiries r)
              (clim:formatting-table (stream :move-cursor t)
                (loop for i in (kpml::gh-history-inquiries r)
                      do
                      (clim:formatting-row (stream)
                        (clim:formatting-cell (stream)
                          (clim:with-drawing-options                     ;; 2.1
                              (stream  :ink (color-selection-for-inquiry-source (fourth i)))
                            (clim:with-output-as-presentation 
                                (stream (first i) 'inquiry)
			      (format stream "~A: " (first i)))))  ;; inq-name
                        (clim:formatting-cell (stream)
                          (clim:with-drawing-options                     ;; 2.1
                              (stream  :ink (color-selection-for-inquiry-source (fourth i)))
                            (if (second i)                       ;; paras
                                (present-paras)
			      (format stream "[no parameters]"))
                            (when *show-cumulative-history-inquiry-sources-explicitly*
                              (clim:with-text-style (stream kpml-i::*fix--bold--6*)
                                (format stream "[~A]" (fourth i))))
			    (if (mousable-spl-term? (third i)) ;; response
                                (present-response)
                              (format stream  " = ~A" (third i)))))))))
            (kpml-i-terpri stream)
            )))))


(defun CUMULATIVE-GH-HARDRECORD ()
  (let ((hardcopy-path
	 (merge-pathnames *default-kpml-hardcopy-directory* "GENERATION-HISTORY.txt")))
    (with-open-file 
        (stream hardcopy-path :direction :output :if-exists :overwrite 
	        :if-does-not-exist :create)
      (macrolet ((present-paras ()
                                '(progn
                                   (format stream "(")
                                   (loop for i2 in (second i)
                                         when (member :formal-parameters *cumulative-display-flags*)
                                         do (format stream "~A" (car i2))
                                         when (member :hubs *cumulative-display-flags*)
                                         do (format stream "[~A]  "  (if (member :id *cumulative-display-flags*)
                                                                         (cdr i2)
                                                                       (symbol-if-term (cdr i2)))))
                                   (format stream ")")))
                 (present-response ()
                                   '(format stream  " = ~A" (if (member :id *cumulative-display-flags*)
                                                                (third i)
                                                              (symbol-if-term (third i))))))
        (unless kpml::*gh-table*
          (format stream "~2%No Information Accumulated....~3%")
          (return-from CUMULATIVE-GH-HARDRECORD nil))
        (kpml::finalize-pending-entries)
        (loop for r in kpml::*gh-table*
              do 
	      (let ((system (kpml::gh-history-system r))
	            (feat   (kpml::gh-history-feature r)))
                ;; 2.1 allow filtering...
                (when (and (kpml::gh-history-inquiries r)
                           (loop for i in (kpml::gh-history-inquiries r)
                                 thereis (history-display-for-inquiry-source-p (fourth i))))
                  (format stream "~%~0T")
                  (format stream "~A:" system)
                  (format stream " ~(~A~) " feat)
                  (kpml-i-terpri stream)
            
                  (when (kpml::gh-history-inquiries r)
                    (loop for i in (kpml::gh-history-inquiries r)
                          do
                          (format stream "~%~10T~A: " (first i))  ;; inq-name
                          (if (second i)                       ;; paras
                              (present-paras)
                            (format stream "[no parameters]"))
                            (when *show-cumulative-history-inquiry-sources-explicitly*
                              (format stream "[~A]" (fourth i)))
			    (if (mousable-spl-term? (third i)) ;; response
                                (present-response)
                              (format stream  " = ~A" (third i)))))
                  (kpml-i-terpri stream)
                  )))))))


(defun SYMBOL-IF-TERM (x)
  (if (and (symbolp x)
	   (boundp x)
	   (kpml::term-graph-p (symbol-value x)))
      (kpml::term-graph-symbol (symbol-value x))
    x))
      

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

(defun STARTUP-CUMULATIVE-GH-FRAME (&optional (reset nil))
  (when (and reset *cumulative-gh-frame*)
    (close-a-window *cumulative-gh-frame*)
    (setf *cumulative-gh-frame* nil))
  (kpml::finalize-pending-entries)
  (let* ((frame (setf *cumulative-gh-frame*
		  (clim:make-application-frame
		   'cumulative-gh-frame
		   :pretty-name 
		   "Cumulative Generation History (KPML)"
		   :left 100 :top 20
		   :width 500 :height 400)))
	    (process
	     (process-run-function "KPML-CGH" 
				      #'run-packaged-frame
				      frame (find-package "KPML"))))
    (push (cons frame process) *frame-process-alist*)
    T))



