(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.
;;;
;;; 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.
;;; ----------------------------------------------------------------------

(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

(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))
  (:menu-bar nil)
  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (: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.")
	  (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 t)
  ()
  (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 t)
  ()
  (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-FUNCTIONS-IN-REGION-OVERVIEW :name "Toggle Function Info" :menu t)
  ()
  (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 t)
  ()
  (let ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	(style :html))
    (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")))
	  (kpml-i-terpri stream)
	  (setf style
	    (clim:accept '(member :html :text) :stream stream
			 #-lispworks :view #-lispworks 'clim:list-pane-view
			 :prompt "Style"
			 :default style))
	  #+lispworks (kpml-i::dialog-end-spacing))
      (ABORT () 
	(setf style nil)))
    (when style (kpml::region-report-to-file 
		 (kpml::collect-all-regions) 
		 :style style))))
   
;;; ----------------------------------------------------------------------
;;; 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*)))

;;; 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)
                                         ;; 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...

#-(or acl3.0 (and lispworks (not postscript-clim)))
(define-region-overview-graph-command 
  (com-HARDCOPY-REGION-OVERVIEW :name "Make Postscript File" :menu t)
  ()
  (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))))))

