(in-package "KPML-I")

;;; File: traversal-graph.lisp

;;; The command TRAVERSAL GRAPH from the inspector brings up 
;;; a window which displays the traversal of the systemic network
;;; as it occurs; for big networks this can get slow.

;;; 0.9.28 dynamic tracing of systemic network traversal...
;;; 2.1    experimental control of text size added for feedback...
;;;        and a bad fix of 1.1 corrected
;;; ----------------------------------------------------------------------

(defvar *graphical-traversal* nil "Flag for producing traversal graphs")
(defvar *traversal-frame* nil "Frame for a traversal graph")
(defvar *graphical-start-pt* nil "Contains starting point for traversal graph")
(defvar *fresh-growth* nil "The last feature grown in a traversal graph")
(defvar *old-fresh-growth* nil "The penultimate feature grown.")

;;; ----------------------------------------------------------------------
;;; 1.1 adds the option of numbering the nodes so that one can see
;;;     the order of generation even in the completed graph.
;;; ----------------------------------------------------------------------

(defvar *trav-graph-node-count* (make-hash-table))
(defvar *trav-graph-count* 0)

;;; ----------------------------------------------------------------------
;;; 2.1 prettifying... these can all be set otherwise, for example by
;;;     a configuration file, if we want to have something different
;;;     for demos, eg.
;;; ----------------------------------------------------------------------

(defvar *fresh-growth-color* clim:+magenta+)
(defvar *traversal-feature-text-size* 8)
(defvar *traversal-system-text-size* 6)

;;; ----------------------------------------------------------------------
;;; The basic frame definition...
;;; ----------------------------------------------------------------------

(clim:define-application-frame 
 TRAVERSAL-GRAPH-FRAME ()
 ((traversal :initform nil)
  (record-id :initform nil)
  (feature-text-size :initform *traversal-feature-text-size*)
  (system-text-size :initform *traversal-system-text-size*)
  )
 (:menu-bar T)	
 (:top-level (clim:default-frame-top-level))
 (:command-table 
  (traversal-graph-frame
   :inherit-from (kpml-resource-inspector)))
  (:panes 
   (mouse-doc   :pointer-documentation
	  :foreground  mouse-doc-fg
	  :background  mouse-doc-bg)
   (info :application
	 :incremental-redisplay T
	 :display-function 'traversal-displayer
	 :initial-cursor-visibility :inactive          ;; 2.0
	 :width 600
	 :foreground inspector-fg
	 :background inspector-bg 
	 :text-style *fix--bold--10*)
   #-lispworks
   (option-palette :accept-values                      ;; 2.1
		   :text-style *sans-serif--roman--6*
		   :scroll-bars nil
		   :height 20
		   :display-function '(clim:accept-values-pane-displayer
				       :align-prompts t
				       :displayer
				       traversal-grapher-palette)
		   :help-callback "Define traversal graph options.")
   )
  (:layouts
   (first (clim:vertically () 
	    info 
	    #-lispworks 
	    (50 (clim:outlining (:thickness 1) option-palette))
	    #-lispworks (20 mouse-doc))
	  )))

;;; ----------------------------------------------------------------------
;;; Font size control palette...
;;; ----------------------------------------------------------------------

(defun TRAVERSAL-GRAPHER-PALETTE (frame stream)
  "Function to display the grapher's options."
  (with-slots (system-text-size feature-text-size) frame
    (clim:formatting-table (stream)
      (clim:formatting-row (stream)
	(clim:formatting-cell (stream)
	  (format stream "System text size:")
	  (hd-accepts system-text-size '(integer 1 30) "System text size"
		      '(clim:slider-view :show-value-p t)))
	(clim:formatting-cell (stream)
	  (format stream "    Feature text size:")
	  (hd-accepts feature-text-size '(integer 1 30) "Feature text size"
		      '(clim:slider-view :show-value-p t)))
	))))

;;; ----------------------------------------------------------------------
;;; Usual commands...
;;; ----------------------------------------------------------------------

(define-traversal-graph-frame-command 
  (com-QUIT-TRAVERSAL-GRAPHER :name "Quit" :menu t)
  ()
  (setf *graphical-traversal* nil)
  (close-a-window clim:*application-frame*))

(define-traversal-graph-frame-command 
    (com-RESET-TRAVERSAL-GRAPH :name "Reset" :menu t)
    ()
  (before-starting-up-traversal-frame)
  (setf (slot-value clim::*application-frame* 'traversal) (make-hash-table))
  (clim:redisplay-frame-pane clim::*application-frame* 'info))

(define-traversal-graph-frame-command 
    (com-NUMBER-TRAVERSAL-GRAPH-NODES :name "Numbering" :menu t)
    ()
  (setf *trav-graph-count-flag* (not *trav-graph-count-flag*)))

(define-traversal-graph-frame-command 
    (com-REDISPLAY-TRAVERSAL-GRAPH :name "Redisplay" :menu t)
    ()
  (clim:redisplay-frame-pane clim::*application-frame* 'info :force-p T))

(define-traversal-graph-frame-command 
    (com-GENERATE-IN-TRAVERSAL-GRAPH :name "Generate" :menu t)
    ()
    (com-generate-sentence))

(define-traversal-graph-frame-command 
  (com-GENERATION-MODES-IN-TRAVERSAL-GRAPH :name "Generation Modes" :menu t)
  ()
  (run-modes))

(define-traversal-graph-frame-command
  (com-GRAPH-STRUCTURE-IN-TRAVERSAL-GRAPH :name "Graph structure" :menu T)
  ()
  (graph-sentence-structure))

;;; ----------------------------------------------------------------------
;;; But the following two mess up the redisplay...
;;; ----------------------------------------------------------------------

#+ignore(define-traversal-graph-frame-command 
  (com-PAUSE-TRAVERSAL :name "Pause" :menu t)
    ()
  (when (and (find *say-process* (cpc:all-processes))
	     (equalp (cpc:process-state *say-process*) "active"))
	(format (clim::get-frame-pane 
		 *resource-development-frame*
		 'inspector)
		"~%<PAUSE>~%")
	(cpc:disable-process *say-process*))
  (clim:redisplay-frame-pane clim::*application-frame* 'info))

#+ignore(define-traversal-graph-frame-command 
  (com-RESUME-TRAVERSAL :name "Resume" :menu t)
    ()
  (when (and *say-process*
	     (find *say-process* (cpc:all-processes)))
    (unless  (equalp (cpc:process-state *say-process*) "active")
      (format (clim::get-frame-pane 
	       *resource-development-frame*
	       'inspector)
	      "~%<RESUME>~%")
      (cpc:enable-process *say-process*))))

;;; ----------------------------------------------------------------------
;;; Make the traversal graph accessible
;;; ----------------------------------------------------------------------

(define-kpml-resource-inspector-command 
  (com-TRAVERSAL-GRAPH :name t :menu nil)
  ()
  (before-starting-up-traversal-frame)
  (startup-a-traversal-frame))

(defun BEFORE-STARTING-UP-TRAVERSAL-FRAME ()
  (if kpml::*collected-features*
      (setf *graphical-start-pts* 
	(mapcar 
	 #'(lambda (f) (cons (first (kpml::who-has-as-output f)) f))
	 kpml::*collected-features*))
    (setf *graphical-start-pts* nil))
  (setf kpml::*cumulate-chooser-activity* :all)
  (setf *trav-graph-count* 0)                         ;; 1.1
  (clrhash *trav-graph-node-count*)
  (setf *graphical-traversal* T)
  (kpml::reset-generation-history))

(defun STARTUP-A-TRAVERSAL-FRAME ()
  (setf *traversal-frame*
    (clim:make-application-frame
     'traversal-graph-frame
     :pretty-name 
     (format nil 
	     "Network Graphical Traversal (ex: ~A)"
	     kpml::*most-recent-example*)
     :left 20 :top 20
     :width 630 :height 400))
  (setf (slot-value *traversal-frame* 'traversal) (make-hash-table))
  (setf (slot-value *traversal-frame* 'record-id) (gensym))
  (process-run-function 
   "KPML-TRAVERSAL"
   #'run-packaged-frame
   *traversal-frame* (find-package "KPML")))

;;; ----------------------------------------------------------------------
;;; Traversal graph display method...
;;;
;;; Uses the cumulative history so that each time the history is updated
;;; the function UPDATE-TRAVERSAL-GRAPH (in substrate/history-cumulation)
;;; is also called. This sets the fresh growth variable to the most
;;; recent system and redisplays the graph pane, which gets us back to
;;; this method here.
;;; ----------------------------------------------------------------------

(defmethod TRAVERSAL-DISPLAYER ((frame traversal-graph-frame) stream)
  (let* ((traversal (slot-value frame 'traversal))
	 (starting-points (copy-list *graphical-start-pts*)))
    
    ;; 2.1 following got moved mistakenly inside the print-function flet
    ;;     which killed both the fresh growth display and the numbering!
    ;;     Rescued to here: it does not do a fresh count if the display
    ;;     method is called twice sucessively without a new growth point
    ;;     (e.g., when we are done and are redisplaying, etc.)
    (if (equal *fresh-growth* *old-fresh-growth*) ;; 1.1
	(setf *fresh-growth* nil)                 ;; stop increment
      (setf *old-fresh-growth* *fresh-growth*))   ;; running wild...

    (flet ((print-function 
	    (node stream) 
	    (if (eq (cdr node) *fresh-growth*)
		(clim:with-drawing-options 
		    (stream :ink *fresh-growth-color*)
		  (display-system-and-its-feature 
		   frame stream (car node) (cdr node) T))
	      (display-system-and-its-feature 
	       frame stream (car node) (cdr node) nil)))
	   (descendents-function (node)
	     (let ((downstreams (kpml::who-has-as-input (cdr node))))
	       (loop for d in downstreams
		   when (gethash d traversal)
		   collect 
		     (if (or (member d *graph-stop-points*) ;; 0.9.29
			     (member (cdr node) *graph-stop-points*))
			 (cons d 'stub)
		       (cons d (gethash d traversal)))))))
      (clim:updating-output (stream :unique-id starting-points)
	(clim:format-graph-from-roots
	 starting-points
	 #'(lambda (node s)
	     (clim:updating-output (s :cache-value node)
	       (print-function node s)))
	 #'descendents-function
	 :generation-separation *vertical-scaling*
	 :within-generation-separation *vertical-scaling*
	 :cutoff-depth nil
	 :merge-duplicates t
	 :duplicate-test #'equal
	 :move-cursor nil
	 :orientation :horizontal
	 :stream stream)))))

(defun DISPLAY-SYSTEM-AND-ITS-FEATURE (frame stream system feature new)
  (cond ((eq feature 'stub) ;; 0.9.29
	 (format stream "..."))
	(t
	 (with-slots (system-text-size feature-text-size) frame
	   (when (and new *trav-graph-count-flag*)
	     (setf (gethash feature *trav-graph-node-count*)
	       (setf *trav-graph-count* (1+ *trav-graph-count*))))
	   (clim:with-text-style (stream *sans-serif--italic--6*)
	     (clim:with-text-size (stream system-text-size)
	       (clim:with-output-as-presentation 
		   (stream system 'system)
		 (if *trav-graph-count-flag*             ;; 1.1
		     (format stream "~A [~A]~%" 
			     system 
			     (gethash feature *trav-graph-node-count*))
		   (format stream "~A~%" system)))))
	   (clim:with-text-style (stream *fix--bold--8*)
	     (clim:with-text-size (stream feature-text-size)
	       (clim:with-output-as-presentation 
		   (stream feature 'feature)
		 (format stream "~A" feature))))))))

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