(in-package "KPML-I")

;;; File: regions-overview-interface.lisp
;;; Author: John; Ober-Ramstadt, Feb97.
;;;
;;; ----------------------------------------------------------------------
;;; Provides graphing for overviews of a grammar resource by region.
;;; 
;;; 2.0.43
;;; 
;;; Makes some of the region manipulation and reporting 
;;; functions directly available from the interface.
;;;
;;; N.B.
;;; Could move the menu into a menu bar so that we can support
;;; more options more easily. Perhaps then print should, for example, be along
;;; with the options for producing reports, which could have suboptions
;;; for html or straight text, etc. instead of bringing up a dialogue
;;; box as done below.
;;;                 (4.0 -- this is now done: John, Bremen, 2004)
;;;
;;; 2.1 variable font size added to see if it is any use and if folks
;;;     would like this facility for other windows.
;;;     overview of where patches are added too.
;;  4.1 macros for radio-box accepts, etc. added.
;;; ----------------------------------------------------------------------

(defvar *region-exclusions* '(kpml::unifyinggates))
(defvar *region-overview-text-size* 6)

(defvar *count-patched-systems* T)      ;; 2.1
(defvar *functions-in-region* nil)      ;; 3.0
(defvar *features-in-region*  nil)      ;; 4.0

  ;; ----------------------------------------------------------------------
  ;; 4.0
  ;;      Move to a menu for more options...
  ;; ----------------------------------------------------------------------

(clim:define-command-table 
 REGION-GRAPHING-TOGGLES-COMMAND-TABLE
    :menu (("...gates" :command com-toggle-gates-in-region-overview)
	   ("...patches" :command com-toggle-patches-in-region-overview)
	   ("...feature information" :command  com-toggle-features-in-region-overview)
	   ("...function information" :command com-toggle-functions-in-region-overview)
	   ))

(clim:define-command-table 
 REGION-REPORTS-COMMAND-TABLE
 :menu
     (("Report of all regions"              :command com-make-region-overview-report)
      ("Postscript of the region Graph "    :command com-hardcopy-region-overview)
      ("Postscript networks for all regions"
                                    :command com-make-postscript-graphs-of-regions)
      ))


(clim:define-presentation-type region-graph-node ())

(clim:define-application-frame region-overview-graph ()
  ((root-regions :initform nil)
   (text-size :initform *region-overview-text-size*)
   (language :initform kpml::curlan)
   (occured :initform nil)
   (region-region :initform (make-hash-table))
   (exclusions :initform nil)
   ;;
   ;; 4.0 and these come in from the resource grapher...
   ;;
   (root-systems :initform nil)
   (mode :initform nil)
   (regions :initform nil)
   (region-graphing-mode :initform nil)
   (languages :initform nil)
   (system-positions                                            ;; 1.1
    :initform (make-hash-table :test #'equal))                  ;; usage changed in 2.1
   (feature-max-y :initform (make-hash-table :test #'equal))    ;; 2.1
   (feature-min-y :initform (make-hash-table :test #'equal))    ;; 2.1
   )

  (:menu-bar T)   ;; 4.0
  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (:command-table ;;4.0
   (region-overview-graph
    :menu
    (("Toggle..."                  :menu    region-graphing-toggles-command-table)
     ("Reports..."                 :menu    region-reports-command-table)
     #-acl3.0("Quit"               :command com-quit-region-overview-grapher)
     )))
  (:panes (graph       :application
		       :incremental-redisplay T
		       :display-function 'region-overview-displayer
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *sans-serif--roman--6*)
	  (option-palette :accept-values
			  :text-style *sans-serif--roman--6*
			  :scroll-bars nil
			  :height 20
			  :display-function '(clim:accept-values-pane-displayer
					      :align-prompts t
					      :displayer
					      region-grapher-palette)
			  :help-callback "Define graphing options.")
	  #+ignore(menu        :command-menu
		       :foreground menu-fg
		       :background menu-bg
		       :text-style *menu-font*)
	  )
  (:layouts (default (clim:vertically () 
		       ;; #-lispworks (30 menu) #+lispworks menu
		       (:fill graph)
		       #+lispworks option-palette
		       #-lispworks 
		       (50 (clim:outlining (:thickness 1) option-palette))
		       )))
  (:command-definer t))

;;; ----------------------------------------------------------------------
;;; Commands for changing views, making reports, etc.
;;; ----------------------------------------------------------------------

(define-region-overview-graph-command 
  (com-TOGGLE-GATES-IN-REGION-OVERVIEW :name "Toggle Gates" :menu nil)
  ()
  (setf Kpml::*include-gates-in-region-overviews-p*
    (not Kpml::*include-gates-in-region-overviews-p*))
  (setf (slot-value clim:*application-frame* 'region-region)
      (kpml::make-region-overview-info))
  (clim:redisplay-frame-pane 
   clim:*application-frame* 'graph :force-p nil))

(define-region-overview-graph-command 
  (com-TOGGLE-PATCHES-IN-REGION-OVERVIEW :name "Toggle Patches" :menu nil)
  ()
  (setf *count-patched-systems* (not *count-patched-systems*))
  (clim:redisplay-frame-pane 
   clim:*application-frame* 'graph :force-p nil))

(define-region-overview-graph-command 
  (com-TOGGLE-FEATURES-IN-REGION-OVERVIEW :name "Toggle Feature Info" :menu nil)
  ()
  (setf *features-in-region* (not *features-in-region*))
  (clim:redisplay-frame-pane 
   clim:*application-frame* 'graph :force-p nil))

(define-region-overview-graph-command 
  (com-TOGGLE-FUNCTIONS-IN-REGION-OVERVIEW :name "Toggle Function Info" :menu nil)
  ()
  (setf *functions-in-region* (not *functions-in-region*))
  (clim:redisplay-frame-pane 
   clim:*application-frame* 'graph :force-p nil))

(define-region-overview-graph-command 
  (com-MAKE-REGION-OVERVIEW-REPORT :name "Report" :menu nil)
  ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(style :html)
	(with-networks nil)
	(with-dependencies nil))
    (restart-case 
	(clim:accepting-values
	    (stream :own-window *own-window*
		    :resynchronize-every-pass t
		    :label "Region report style selection" 
		    :exit-boxes 
		    '((:exit "Click to start report")
		      (:abort "Click here to cancel")))
          (radio-box-accept style (html :text) "Style")
          (on-or-off with-networks "With systemic networks")
          (on-or-off with-dependencies "With region dependencies")
	  (format stream "~%Network postscript options...~%")
          (on-or-off *suitable-for-figures?*  "Single page graphs")
          (on-or-off *grapher-header* "Networks with titles")
	  #+lispworks (kpml-i::dialog-end-spacing))
	(ABORT () 
	       (setf style nil)))
    (when style (kpml::region-report-to-file 
		 (kpml::collect-all-regions) 
		 :style style
		 :with-networks with-networks
		 :with-dependencies with-dependencies))))
   
;;; ----------------------------------------------------------------------
;;; 2.1 region node actions ordered more appropriately and grouped
;;;     here...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action spawn-region-graph-node
    (region-graph-node nil region-overview-graph 
		       :documentation "Spawn a dependent regions graph")
  (object)
  (with-slots (language exclusions)
      clim:*application-frame*
    (create-a-region-overview object
			      :language language
			      :exclusions exclusions)))

(clim:define-presentation-action present-region-graph-node
    (region-graph-node nil region-overview-graph
		       :documentation "Graph region")
  (object)
  (graph-under-current-options object :region-flag T))

(clim:define-presentation-action SHOW-REGION-INPUTS
    (region-graph-node nil region-overview-graph
		       :documentation "Show input features")
  (object)	
  (let ((stream
	 (clim:get-frame-pane 
	  kpml-i::*resource-inspector-frame* 'kpml-i::inspector))
	(features (kpml::inputs-of-region object)))
    (if features
	(progn
	  (kpml-i::pen-pprint-for-clim
	   (format nil "~%Input features of region ~A are:" object)
	   ':string stream)
	  (kpml-i-terpri stream)
	  (loop for f in features
	      do (clim:with-output-as-presentation
		     (stream f 'feature)
		   (format stream " ~S" f))))
      (kpml-i::pen-pprint-for-clim
       (format nil "~%Region ~A has no input features." object)
       ':string stream))))

(clim:define-presentation-action COLLECT-REGION-INPUTS
    (region-graph-node nil region-overview-graph
		       :documentation "Collect input features")
  (object)	
  (loop for f in (kpml::inputs-of-region object)
      do (pushnew f kpml::*collected-features*)))


;;; 2.1 added...

(clim:define-presentation-action SHOW-REGION-OUTPUTS
    (region-graph-node nil region-overview-graph
		       :documentation "Show output features")
  (object)	
  (let ((stream
	 (clim:get-frame-pane 
	  kpml-i::*resource-inspector-frame* 'kpml-i::inspector))
	(features (kpml::output-features-of-region object)))
    (if features
	(progn
	  (kpml-i::pen-pprint-for-clim
	   (format nil "~%Output features of region ~A are:" object)
	   ':string stream)
	  (kpml-i-terpri stream)
	  (loop for f in features
	      do (clim:with-output-as-presentation
		     (stream f 'feature)
		   (format stream " ~S" f))))
      (kpml-i::pen-pprint-for-clim
       (format nil "~%Region ~A has no output features." object)
       ':string stream))))

(clim:define-presentation-action COLLECT-REGION-OUTPUTS
    (region-graph-node nil region-overview-graph
		       :documentation "Collect output features")
  (object)	
  (loop for f in (kpml::output-features-of-region object)
      do (pushnew f kpml::*collected-features*)))

;;; 4.0 added...

(clim:define-presentation-action GRAPH-FROM-OUTPUTS
    (region-graph-node nil region-overview-graph
		       :documentation "Graph network from output features")
  (object)	
  (setf kpml::*collected-features* nil)
  (loop for f in (kpml::output-features-of-region object)
      do (pushnew f kpml::*collected-features*))
  (create-a-resource-graph-from-features kpml::*collected-features*)
  )

;;; 3.0 added...

(clim:define-presentation-action SHOW-FUNCTIONS-OF-REGION
    (region-graph-node nil region-overview-graph
		       :documentation "Show functions")
  (object)	
  (let ((stream
	 (clim:get-frame-pane 
	  kpml-i::*resource-inspector-frame* 'kpml-i::inspector)))
    (multiple-value-bind (l functions)
        (kpml::fetch-region-function-usage object)
      (cond ((> l 0)
             (format stream "~%~0TRegion ~A uses the following ~A function~:P:~%" object l)
             (loop for f in functions
                   do
                   (clim:with-output-as-presentation (stream (cons f object) 'microfunction)
		     (format stream " ~@(~A~)" f))))
            (t
             (format stream "~%~0TRegion ~A uses no functions."))))))


;;; 2.1 added...
(clim:define-presentation-action SHOW-PATCHED-SYSTEMS
    (region-graph-node nil region-overview-graph
		       :documentation "Show patched systems")
  (object)	
  (let ((stream
	 (clim:get-frame-pane 
	  kpml-i::*resource-inspector-frame* 'kpml-i::inspector))
	(systems (kpml::patched-systems-of-region object)))
    (if systems
	(progn
	  (kpml-i::pen-pprint-for-clim
	   (format nil "~%Patched systems of region ~A are:" object) ':string stream)
	  (kpml-i-terpri stream)
	  (loop for s in systems
	      do (clim:with-output-as-presentation
		     (stream s 'system)
		   (format stream " ~S" s))))
      (kpml-i::pen-pprint-for-clim
       (format nil "~%Region ~A has no patched systems." object)
       ':string stream))))



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

(defun DISPLAY-REGION-OVERVIEW (region &key (language kpml::curlan)
					    (exclusions *region-exclusions*))
  (kpml::make-region-overview-info)
  (create-a-region-overview
   region
   :language language
   :exclusions exclusions)
  (values))

;;; ----------------------------------------------------------------------
;;; Display methods...
;;; ----------------------------------------------------------------------

(defun REGION-GRAPHER-PALETTE (frame stream)
  "Function to display the grapher's options."
  (with-slots (text-size) frame
    (clim:formatting-table (stream)
      (clim:formatting-row (stream)
	(clim:formatting-cell (stream)
	  (format stream "Text size: (~A)" text-size)
	  (hd-accepts text-size '(integer 1 30) "Text size"
		      '(clim:slider-view :show-value-p t)))
	(clim:formatting-cell (stream)
	  (if Kpml::*include-gates-in-region-overviews-p*
	      (format stream "Gates are included.")
	    (format stream "Gates are not included.")))))))

(defmethod REGION-OVERVIEW-DISPLAYER ((frame region-overview-graph) stream)
  (with-slots (root-regions language occured region-region exclusions
	       text-size)
      clim:*application-frame*
    (flet ((region-descendents (r) (first (gethash r region-region))))
      (let ((kpml::curlan language))
	(setf occured root-regions)
	(clim:with-text-size (stream text-size)
	  (clim:updating-output (stream :unique-id root-regions)
	    (clim:format-graph-from-roots
	     (mapcar #'(lambda (r) (cons :first r)) root-regions)
	     #'(lambda (node s)
		 (clim:updating-output (s :cache-value node)
		   (apply #'region-print-function 
			  (list node s))))
	     #'(lambda (node)
		 (let* ((region (cdr node))
			(occurence (car node)))
		   (if (or (eq occurence :second)
			   (member region exclusions))
		       nil
		     (let* ((children (region-descendents region))
			    (result (set-difference children occured))
			    (seconds (set-difference children result)))
		       (if children
			   (progn
			     (loop for o in result do (pushnew o occured))
			     (append
			      (mapcar #'(lambda (r) (cons :first r)) 
				      (set-difference result exclusions))
			      (mapcar #'(lambda (r) 
					  (if (region-descendents r)
					      (cons :second r)
					    (cons :first r))) seconds)))
			 nil)))))
	     :generation-separation (+ *vertical-scaling* 10)
	     :within-generation-separation *inter-generation-scaling*
	     :cutoff-depth nil
	     :merge-duplicates T
	     :duplicate-test #'equal
	     :move-cursor t
	     :orientation *hardcopy-structure-orientation*
	     :stream stream)))))))

(defun REGION-PRINT-FUNCTION (node stream)
  (cond ((eq (car node) :first)
	 (let* ((r (cdr node))
		(info (cdr (gethash 
			    r (slot-value 
			       clim:*application-frame* 'region-region))))
		(nsystems (first info))
		(ninputs (second info))
		(noutputs (third info))
                (npatched (fourth info)))
	   (macrolet ((print-region ()
                                    '(clim:with-output-as-presentation
	                                 (stream r 'region-graph-node)
	                               (clim:surrounding-output-with-border
		                           (stream :shape :rectangle)
	                                 (clim:with-text-face (stream :bold)
		                           (format stream "~A~%" r))
	                                 (format stream "~A system~:P~%~A input~:P~%~A output~:P" 
		                                 nsystems ninputs noutputs)
					 ;; 4.0
					 (when *features-in-region*
                                           (format stream "~%~A feature~:P" 
						   (kpml::region-feature-count r)))
                                         ;; 3.0
                                         (when *functions-in-region*
                                           (format stream "~%~A function~:P" 
						   (kpml::region-function-count r)))
                                         (when (and *count-patched-systems*
                                                    (> (if npatched npatched 0) 0))
                                           (format stream "~%~A patched." npatched))
                                         ))))
             (if (and *count-patched-systems*
                      (> (if npatched npatched 0) 0))
                 (clim:with-text-size (stream :larger)
                   (clim:with-text-face (stream :italic)
                     (clim:with-drawing-options (stream :ink clim:+red+)
                       (print-region))))
               (print-region)))))
	(t
	 (clim:with-output-as-presentation
	     (stream (cdr node) 'region-graph-node)
	   (clim:with-text-face 
	       (stream :italic)
	     (format stream "~A" (cdr node)))))))


;;; ----------------------------------------------------------------------
;;; 3.0 encapsulated frame starts for easier updates...
;;; ----------------------------------------------------------------------

(defun CREATE-A-REGION-OVERVIEW (region &key (language kpml::curlan)
					     (exclusions *region-exclusions*))
  (startup-region-overview-frame region exclusions language
                                 :frame-tool-label region))


(define-region-overview-graph-command 
  (com-QUIT-REGION-OVERVIEW-GRAPHER :name "Quit" :menu T)
  ()
  (close-a-window clim:*application-frame*))

;;; ----------------------------------------------------------------------
;;; ... And the obligatory hardcopy options...

;; 4.0 -- have to do this explicitly now since we build the
;;        menus above rather than on-the-fly...
;;
#+(or acl3.0 (and lispworks (not postscript-clim)))
(define-region-overview-graph-command 
  (com-HARDCOPY-REGION-OVERVIEW :name "Make Postscript File" :menu nil)
  ()
  (clim:notify-user launching-graph
		    "No postscript capability in this Lisp version!"))


#-(or acl3.0 (and lispworks (not postscript-clim)))
(define-region-overview-graph-command 
  (com-HARDCOPY-REGION-OVERVIEW :name "Make Postscript File" :menu nil)
  ()
  (hardcopy-region-overview 
   (merge-pathnames  *default-kpml-hardcopy-directory* 
		     (make-hardcopy-filename 
		      (concatenate 'string
			(string kpml::curlan) "-REGIONS")))
   (not *suitable-for-figures?*)
   clim:*application-frame*))

(defun HARDCOPY-REGION-OVERVIEW (filename multipage? launching-frame)
  (with-slots (root-regions language occured region-region exclusions)
      launching-frame
    (flet ((region-descendents (r) (first (gethash r region-region))))
      (with-open-file 
	  (fstr filename :direction :output :if-exists :overwrite 
	   :if-does-not-exist :create)
	(clim::with-output-to-postscript-stream 
	    (pstr fstr :multi-page multipage?)
	  (setf occured root-regions)
	  (clim:format-graph-from-roots
	   (mapcar #'(lambda (r) (cons :first r)) root-regions)
	   #'region-print-function
	   #'(lambda (node)
	     (let* ((region (cdr node))
		    (occurence (car node)))
	       (if (or (eq occurence :second)
		       (member region exclusions))
		   nil
		 (let* ((children (region-descendents region))
			(result (set-difference children occured))
			(seconds (set-difference children result)))
		   (if children
		       (progn
			 (loop for o in result do (pushnew o occured))
			 (append
			  (mapcar #'(lambda (r) (cons :first r)) 
				  (set-difference result exclusions))
			  (mapcar #'(lambda (r) 
				      (if (region-descendents r)
					  (cons :second r)
					(cons :first r))) seconds)))
		     nil)))))
	 :generation-separation (+ *vertical-scaling* 10)
	 :within-generation-separation *inter-generation-scaling*
	 :cutoff-depth nil
	 :merge-duplicates T
	 :duplicate-test #'equal
	 :move-cursor t
	 :orientation *hardcopy-structure-orientation*
	 :stream pstr)))
    (when *auto-print*
      #+allegro (excl:shell (format NIL "lpr ~A" filename))
      #+lucid   (lcl:shell (format NIL "lpr ~A" filename))))))


  ;; ----------------------------------------------------------------------
  ;; 4.0
  ;;       And a new hardcopy function, this one iterates over all
  ;;       the regions and makes a postscript file for the system
  ;;       network and the region dependency graph for each
  ;;       region. Only really makes sense for a  
  ;;       Lisp that really supports postscript output, Lispworks
  ;;       4.1.19 doesn't quite make it and makes postscript files
  ;;       that are only one size; Allegro 5+ appears quite happy and
  ;;       produces files that are quite usable. 
  ;;
  ;;       Relies on the standard network graphing function: 
  ;;
  ;;          HARDCOPY-GRAPH 
  ;;             (filename multipage? launching-graph 
  ;;                       &optional (hardcopy-font *hardcopy-font*))
  ;;
  ;;       From resource-grapher-interface.lisp, and so takes on
  ;;       all the appearance settings that are defined for graphs
  ;;       there. Also relies on the application frame providing 
  ;;       most of the values it needs in frame-slots, which are
  ;;       therefore also added into the region overview frame
  ;;       for convenience and re-use.
  ;;
  ;;       Note that the idea here is that the Region Overview
  ;;       Tool makes two directories full of postscript files
  ;;       of the relevant graphs, then it is up to the user to
  ;;       get these into a suitable format (pdf, jpg, etc.) for
  ;;       placing in the right location to be picked up by
  ;;       the hrefs automatically generated in the region
  ;;       reports. The names at least should be correct.
  ;;
  ;; ----------------------------------------------------------------------

#-(or acl3.0 (and lispworks (not postscript-clim)))
(define-region-overview-graph-command 
  (com-MAKE-POSTSCRIPT-GRAPHS-OF-REGIONS :name "Make Postscript Graphs of Regions" :menu nil)
  ()
  (with-slots 
   (root-regions language occured region-region exclusions
		 region-graphing-mode languages regions root-systems) 
   clim:*application-frame*
   
   (let* ((original-root-regions root-regions)
	  (multipage? (not *suitable-for-figures?*))
	  (root-dir
	   (kpml::coerce-directory
	    (merge-pathnames  
	     (concatenate 'string
			  (string kpml::curlan) "-REGIONS")
	     *default-kpml-hardcopy-directory* 
	     )))
	  (root-deps
	   (kpml::coerce-directory (merge-pathnames root-dir "deps")))
	  (root-nets
	   (kpml::coerce-directory (merge-pathnames root-dir "networks"))))
     
    (kpml::create-a-directory-or-warn root-dir)
    (kpml::create-a-directory-or-warn root-deps)
    (kpml::create-a-directory-or-warn root-nets)

    (flet ((make-dep-file-name (region)
	     (merge-pathnames (concatenate 'string (string region) ".ps") root-deps))
	   (make-net-file-name (region)
	     (merge-pathnames (concatenate 'string (string region) ".ps") root-nets)))

	   (setf kpml::*resource-graphing-region-restricted?* t)
	   (setf region-graphing-mode T)
	   (setf languages (list kpml::curlan))

	   (loop for r in kpml::regions
		 as filename1 = (make-dep-file-name r)
		 as filename2 = (make-net-file-name r)
		 as roots = (kpml::standard-region-graphing  r)
		 ;; unless (member r exclusions)
		 do 

		 ;; the following just set frameslots so that the
		 ;; function calls below will get the right
		 ;; information when they produce their graphs...
		 ;;
		 (setf root-systems roots)
		 (setf root-regions (list r))
		 (setf regions (list r))

		 (hardcopy-region-overview filename1 multipage? clim:*application-frame*)
		 (hardcopy-graph           filename2 multipage? clim:*application-frame*)
		 )

	   ;; restore the starting position so that redisplay  
	   ;; of the dependency graph can resume as it was...
	   ;;
	   (setf root-regions original-root-regions)
	   ))))

