(in-package "KPML-I")

;;; File: chooser-display.lisp
;;; John:Dec 29, 1995: Ober-Ramstadt...
;;;
;;; Well, those choosers always did look a bit ugly otherwise...
;;;
;;; Following modelled on resource-graphing...
;;; Trigger a pop-up graphical display of a chooser definition
;;; (always for curlan) by
;;;    (kpml-i::CREATE-A-CHOOSER-GRAPH chooser-name)
;;; This will be the standard action on describing a chooser if
;;; :choosers are on the list kpml::*pop-ups*.
;;; 1.1 current chooser added to frame slots.

(defvar *chooser-grapher* nil)
(defvar *chooser-display-process*)
(defvar *displayed-chooser-name* nil)
(defvar *simult-chooser-display-limit* 4)
(defvar *show-generation-paths* T)          ;; 1.2 only used for choosers now
(defvar *called-from-chooser-display* NIL)  ;; 4.0

(clim:define-application-frame chooser-display-graph ()
  ((root-definition :initform nil)
   (record :initform nil)                                                          ;; 3.0
   (displayed-chooser-name :initform nil))
  (:top-level (clim:default-frame-top-level  :prompt clim-prompt-function))
  (:panes (graph       :application
		       :display-function 'chooser-graph-displayer                  ;; 3.0
		       :foreground resource-graph-fg
		       :background resource-graph-bg
		       :text-style *fix--bold--10*)
	  (menu        :command-menu
		       :stream-foreground menu-fg
		       :stream-background menu-bg			
		       :default-text-style *fix--bold--12*))
  (:layouts (default (clim:horizontally () graph)))
  (:command-table 
  (chooser-display-commands
   :inherit-from (kpml-resource-inspector))))

(defmethod CHOOSER-GRAPH-DISPLAYER ((frame chooser-display-graph) stream)
  (let ((gen-sep 20))
    (with-slots 
     (record root-definition) frame
     (clim:format-graph-from-root
      `(:action ,root-definition ,record)
      #'extract-chooser-node
      #'get-chooser-node-children
      :orientation :vertical
      :center-nodes T
      :generation-separation gen-sep
      :within-generation-separation gen-sep
      :move-cursor t
      :orientation :vertical
      :stream stream))))

;;; ----------------------------------------------------------------------
;;; 1.0.8
;;;   spreading out of related chooser displays with tracing was not
;;;   working. The patch of 0.9.36 was not incorporated here; now added.
;;; 2.1
;;;   reports what constituent the information is for if relevant
;;; 3.1
;;;   generic startup
;;; ----------------------------------------------------------------------

(defun MAKE-A-CHOOSER-GRAPH (chooser-name record 
			     &optional (offset nil)(example-name nil)(for-constituent nil))
  (make-a-chooser-graph-internal
   chooser-name record offset example-name for-constituent
   :frame-tool-label chooser-name))


(define-chooser-display-graph-command 
  (com-QUIT-CHOOSER-GRAPHER :name "Quit display" :menu t)
  ()
  (close-a-window clim:*application-frame*))



#-(or (and lispworks (not postscript-clim)) aclpc)
(define-chooser-display-graph-command 
    (com-PRINTGRAPH-CH :name "Hardcopy" :menu t)
    ()
  (with-slots (displayed-chooser-name) clim:*application-frame*
    (hardcopy-chooser-display
     (clim:get-frame-pane clim:*application-frame* 'graph) 
     (merge-pathnames  *default-kpml-hardcopy-directory* 
		       (make-hardcopy-filename 
			(if displayed-chooser-name displayed-chooser-name
			  "CHOOSER")))
     (not *suitable-for-figures?*))))

;; 2.1
(define-chooser-display-graph-command 
  (com-CHOOSER-DISPLAY-REDISPLAY :name t  :menu t)
  ()
  (clim:redisplay-frame-pane clim:*application-frame* 'graph :force-p t))

(define-chooser-display-graph-command 
  (com-CHOOSER-DISPLAY-MODES :name t  :menu t)
  ()
  (with-slots (displayed-chooser-name) clim:*application-frame*
    (chooser-display-modes-from-grapher)
    (case *replace-current-graph* 
      (printgraph 
       (setf *replace-current-graph* 'no)
       (hardcopy-chooser-display
	(clim:get-frame-pane clim:*application-frame* 'graph) 
	(merge-pathnames  *default-kpml-hardcopy-directory* 
			  (make-hardcopy-filename 
			   (if displayed-chooser-name displayed-chooser-name
			     "CHOOSER")))
	(not *suitable-for-figures?*)))
      (yes
       (create-a-chooser-graph displayed-chooser-name)
       (close-a-window clim:*application-frame*)
       )
      (no
       (create-a-chooser-graph displayed-chooser-name))
      (no-action nil))))



;;; ----------------------------------------------------------------------
;;; Starter wrapper...

(defun RUN-CHOOSER-GRAPHER 
  (*package* *chooser-grapher*)
  (declare (special *package* *chooser-grapher*))
  (setf *package* (find-package "KPML"))
  (clim:run-frame-top-level *chooser-grapher*))

;;; ----------------------------------------------------------------------
;;; 0.9.5 following was not setting up the gh-table
;;;       prior to trying to graph with history...
;;; 2.1   allow restriction to the chooser for a specific constituent (only
;;;       does something when we graph with history information folded in)

(defun CHOOSER-RELEVANT-FOR-CONSTITUENT-P (e for-constituent)
  (or (not for-constituent)
      (and (equal (kpml::gh-history-constituent e) 'kpml::-top-)
           (member kpml::*structure-graph-top-node* for-constituent 
                   :test #'equal))
      (member (kpml::gh-history-constituent e) for-constituent
              :test #'equal)))

(defun CREATE-A-CHOOSER-GRAPH (chooser-name &optional (for-constituent nil))
  (unless chooser-name 
    (clim:notify-user clim:*application-frame* "No chooser!")
    (return-from CREATE-A-CHOOSER-GRAPH nil))
  (kpml::finalize-pending-entries)
  (let ((records 
	 (if (and *show-generation-paths*
		  kpml::*gh-table*)
	     (loop for e in kpml::*gh-table*
		 when (and 
                       (eq (kpml::fetch-system-chooser (kpml::gh-history-system e))
			   chooser-name)
                       (chooser-relevant-for-constituent-p e for-constituent))
                 collect (cons 
			  (kpml::gh-history-example e)
			  (kpml::gh-history-inquiries e)))
	   nil))
        (offset (gensym)))
    (if records
	(if (> (length records) *simult-chooser-display-limit*)
	    (let* ((examples (remove-duplicates (mapcar #'car records)))
		   (stream nil)
		   (examples-to-display
		    #-(and acl3.0 aclpc)
		    (clim:accepting-values
			(stream :own-window *own-window*
				:scroll-bars :vertical
				:resynchronize-every-pass t
				:label "Restrict views" :exit-boxes 
				'((:exit "Click here to display")
				  (:abort "Click here to cancel")))
		      (setf examples
			(clim:accept `(clim:subset-sequence 
				       ,(sort examples #'string<))
				     :view 
				     #-lispworks 'clim:list-pane-view 
				     #+lispworks clim:+textual-dialog-view+
				     :stream stream
				     :prompt 
				     "Display choosers as used in examples: "
				     :default examples)))
		    #+(and acl3.0 aclpc)
		    (kpml::get-a-subset-from 
		     (sort examples  #'string<)
		     examples "Display choosers as used in examples: ")))
	      (loop for (example . rec) in records
		  when (member example examples-to-display)
		  do (make-a-chooser-graph 
                      chooser-name rec offset example for-constituent)))
	  (loop for (example . rec) in records
            do (make-a-chooser-graph 
                chooser-name rec offset example for-constituent)))
      (make-a-chooser-graph chooser-name nil))))



(defvar *cg-offset* nil)



#-(or acl3.0 (and lispworks (not postscript-clim)))
(defun HARDCOPY-CHOOSER-DISPLAY (graph filename multipage?)
  (declare (ignore graph))
  (with-slots (root-definition displayed-chooser-name) clim:*application-frame*
    (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?)
	(when *grapher-header*
	  (clim:with-text-style  
	      (pstr *fix--bold--16*)
	    (format pstr "Definition of chooser: ~A (~A; ~A)~5%~0T"
		    displayed-chooser-name kpml::curlan (kpml::time-stamp))))
	(clim:format-graph-from-root
	 `(:action ,root-definition nil)
	 #'extract-chooser-node
	 #'get-chooser-node-children
	 :orientation :vertical
	 :center-nodes T
	 :generation-separation *hardcopy-vertical-scaling*
	 :within-generation-separation *hardcopy-vertical-scaling*
	 :move-cursor t
	 :orientation :vertical
	 :stream pstr)
	fstr))
    (when *auto-print*
      #+allegro (excl:shell (format NIL "lpr ~A" filename))
      #+lucid   (lcl:shell (format NIL "lpr ~A" filename)))))

#+(or acl3.0 (and lispworks (not postscript-clim)))
(defun HARDCOPY-CHOOSER-DISPLAY (graph filename multipage?)
  (kpml::warning "No postscript support in this CLIM"))
;;; ----------------------------------------------------------------------

(defun EXTRACT-CHOOSER-NODE (pres stream)
  (with-slots (displayed-chooser-name) clim:*application-frame*
    (if (kpml::fetch-chooser-info 
	 displayed-chooser-name 'kpml::patch-status)
	(clim:with-text-face (stream :italic)
	  (extract-chooser-node-intern pres stream))
      (extract-chooser-node-intern pres stream))))

(defun EXTRACT-CHOOSER-NODE-INTERN (pres stream)
  (let ((type (first pres))
	(value (second pres))
	(rec   (first (third pres))))
    (case type
      (:action
       (let ((*standard-output* stream)
	     (*print-right-margin* 20))
	 (clim:surrounding-output-with-border
	     (stream :shape :rectangle)
	   (clim:with-text-style  
	       (stream kpml-i::*fix--bold--8*)
	     (case (caar value)
	       (kpml::ask
		(intertwine-q-quiries (second (car value)) rec stream))
	       (kpml::identify
		(intertwine-id-quiries (first value) rec stream))
	       (otherwise
		(pen-pprint-for-clim (first value) nil stream))
	       )))))
      (:response
       (clim:with-text-style  
	   (Stream kpml-i::*fix--bold--8*)
	 (clim:with-text-face 
	     (stream '(:italic))
	   (if rec
	       (clim:with-drawing-options 
		   (stream :ink clim:+magenta+)
		 (format stream "~A" (first value)))
	     (format stream "~A" (first value)))))))))


(defun INTERTWINE-Q-QUIRIES (quiry rec stream)
  (unless rec 
    (pen-pprint-for-clim quiry quiry stream)
    (return-from INTERTWINE-Q-QUIRIES nil))
  (clim:with-drawing-options 
      (stream :ink clim:+magenta+)
    (output-inquiry-with-actual-paras rec stream)))
  
(defun INTERTWINE-ID-QUIRIES (quiry rec stream)
  (unless rec 
    (pen-pprint-for-clim quiry quiry stream)
    (return-from INTERTWINE-ID-QUIRIES nil))
  (clim:with-drawing-options 
      (stream :ink clim:+magenta+)
    (output-inquiry-with-actual-paras 
     rec stream (second quiry))))

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

(defun GET-CHOOSER-NODE-CHILDREN (pres)
  (let ((type (first pres))
	(current (first (second pres)))
	(rec (third pres)))
    (case type
      (:action
       (case (first current)
	 (kpml::ask
	  (mapcar #'(lambda (resp)
		      `(:response ,resp ,(if (eq (third (first rec)) (first resp))
					     (if (cdr rec)
						 (cdr rec)
					       '(:terminal))
					   nil)))
		  (cddr current)))
	 (kpml::identify
	  (let ((next (cdr (second pres)))
		(rec-2 (if (eq (first (third current)) (caar rec))
			   (cdr rec)
			 rec)))
	    (if next
		`((:action ,next ,rec-2))
	      nil)))
	 (otherwise
	  (let ((next (cdr (second pres))))
	    (if next
		`((:action ,next ,rec))
	      nil)))))
      (:response
       (let ((next (cdr (second pres))))
	 (if next
	     `((:action ,next ,rec))
	   nil))))))

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

(defun CHOOSER-DISPLAY-MODES-FROM-GRAPHER
  (&optional
   (stream (clim::frame-top-level-sheet clim:*application-frame*)))
  (clim:accepting-values
   (stream :own-window *own-window*
	   :scroll-bars :vertical
	   :resynchronize-every-pass t
	   :label "Resource Grapher Display Modes (Choosers)" :exit-boxes 
	   '((:exit "Click here to exit")(:abort "")))
   (radio-box-accept kpml::curlan kpml::all_languages "Current language             ............")
   (kpml-i-terpri stream)
   (kpml-i::on-or-off 
    *show-generation-paths*
    "Generation paths shown       ............")
   (kpml-i-terpri stream)
   (setf *vertical-scaling*
	 (clim:accept 'clim:integer :stream stream
		      :view #-lispworks 'clim:list-pane-view 
                            #+lispworks clim:+textual-dialog-view+
		      :prompt "Vertical scaling             ............"
		      :default *vertical-scaling*))
   (kpml-i-terpri stream)
   (setf *hardcopy-vertical-scaling*
	 (clim:accept 'integer :stream stream
		      :view #-lispworks 'clim:list-pane-view 
                            #+lispworks clim:+textual-dialog-view+
		      :prompt "Hardcopy vertical scaling    ............"
		      :default *hardcopy-vertical-scaling*))
   (kpml-i-terpri stream)
   (setf *default-kpml-hardcopy-directory*
	 (clim:accept 'clim:pathname :stream stream
		      #+lispworks :view
		      #+lispworks clim:+textual-dialog-view+
		      :prompt "Hardcopy directory           ............"
		      :default *default-kpml-hardcopy-directory*))
   (kpml-i-terpri stream)
   (kpml-i::on-or-off 
    *grapher-header*
    "Hardcopy with header         ............")
   (kpml-i-terpri stream)
   (kpml-i::on-or-off 
    *suitable-for-figures?*
    "Suitable for eps (ie. not multipage)?  ..")
   (kpml-i-terpri stream)
   (radio-box-accept *replace-current-graph* 
                     (yes no 
                          #-(or lispworks aclpc)
                          printgraph 
                          no-action) "Replace current graph        ............")
   ))



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

(defun OUTPUT-INQUIRY-WITH-ACTUAL-PARAS (i stream &optional (id-fun nil))
  (clim:with-output-as-presentation 
      (stream (first i) 'inquiry)
    (format stream "~A: " (first i)))  ;; inq-name
  (if (second i)                       ;; paras
      (loop for i2 in (second i)
	  do (kpml-i-terpri stream)
	  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)
		 (let ((sit (symbol-if-term (cdr i2))))
		   (if sit sit "SPL term with no name"))))))
    (format stream "~%[no parameters]"))
  (when (mousable-spl-term? (third i)) ;; response
    (format stream " = ")
    (when (and id-fun
	       (member :formal-parameters *cumulative-display-flags*))
      (format stream "~A" id-fun))
    (clim:with-output-as-presentation 
	(stream (third i) 'spl-term)
      (format 
       stream  " [~A]~2%" 
       (if (member :id *cumulative-display-flags*)
	   (third i)
	 (symbol-if-term (third i)))))))

;;; ----------------------------------------------------------------------
;;; 1.0.12
;;; 
;;; Note that the chooser-display should be redone to use proper frame
;;; slots for the graph-local values sometime soon. Added for 1.1.

(define-chooser-display-graph-command 
  (com-BLANK-SPACE-CHOOSER-OPTIONS :name t)
    ()
  (with-slots (displayed-chooser-name) clim:*application-frame* ;; 1.1
    (case
	(menu-choose
	 '(("Cumulative history display flags" :value :display-style)
	   ("Show systems of chooser" :value :systems)
	   ("Show inquiries of chooser" :value :inquiries)
	   ("Trace inquiries of chooser" :value :trace)
	   ("Untrace inquiries of chooser" :value :untrace)
	   ("Edit chooser" :value :edit)))
      (:display-style 
       ;; 4.0 an unfortunate oversight causing an attempt to redisplay
       ;;     a window that might not even be there...
       ;;
       (let ((*called-from-chooser-display* T))
	 (declare (special *called-from-chooser-display*))
	 (com-HISTORY-DISPLAY-OPTIONS))
       ;; 2.1
       (clim:redisplay-frame-pane clim:*application-frame* 'graph :force-p t))
      (:inquiries
       (com-SHOW-INQUIRIES-OF-CHOOSER displayed-chooser-name))
      (:trace
       (com-TRACE-INQUIRIES-OF-CHOOSER displayed-chooser-name))
      (:untrace
       (com-UNTRACE-INQUIRIES-OF-CHOOSER displayed-chooser-name))
      (:systems
       (com-SYSTEMS-OF-CHOOSER displayed-chooser-name))
      (:edit
       (com-EDIT-CHOOSER displayed-chooser-name)))))

(clim:define-presentation-to-command-translator chgraph-blank-space-options
    (clim:blank-area com-blank-space-chooser-options chooser-display-commands
		     :documentation "Chooser Tracing and Display Options")
  (x y)
  (declare (ignore x y))
  (values))



