;;; Simple sheet hierarchy viewer

(in-package :cl-user)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Package definition
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defpackage :glimpse
  (:use :clim :clim-lisp)
  (:export "GLIMPSE"))

(in-package :glimpse)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Parameters used within Glimpse; the user might like to modify these.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Number the glimpse incarnation; used mainly for frame-prettyname
(defparameter *glimpse-proc-num* 0)

;;; Size of indent to use, when *tree-output-type* is :text
(defparameter *tree-output-indent* 4)

;;; Size of indent increment to use, when *tree-output-type* is :text
(defparameter *tree-indent-increment* 4)

;;; Style of output to use for hierarchy; :text (textual) or :graph (graphical)
;;;(defparameter *tree-output-type* :graph)

;;; ::FIXME:: if :graph is specified here, we have problems because the graph
;;;           doesn't fit on the pane, but the scroll bar updates and pane
;;; resizing DON'T HAPPEN! At least when we output text, the pane is sized so
;;; it can be scrolled!

(defparameter *tree-output-type* :text)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Define application frame (will become the CLOS class for the application)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-application-frame glimpse ()
  ()
  (:panes (app :application
	       :display-time t
	       :scroll-bars t
	       :height 250
	       :end-of-line-action :allow)
	  (doc :pointer-documentation)
	  (int :interactor
	       :display-time t
	       :scroll-bars :vertical
	       :height 350 :width 550))
  (:layouts (default
	      (vertically ()
			  app
			  int
			  doc))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Command definitions. Currently they're text input commands, should
;;; move to mouse gesture (or keyboard gesture) commands instead.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-glimpse-command (com-clear-windows :name t) ()
  (window-clear (find-pane-named *application-frame* 'app))
  (window-clear (find-pane-named *application-frame* 'int)))

(define-glimpse-command (com-quit :name t) ()
  (frame-exit *application-frame*))

(define-glimpse-command (com-show-sheet-hierarchy :name t) ()
  (let ((pane (find-pane-named *application-frame* 'app)))
    ;; We lose the output history, but I think for our purposes that's ok
    (window-clear pane)
    (display-sheet-hierarchy *application-frame* pane)))

(define-glimpse-command (com-show-processes :name t) ()
  (let ((pane (find-pane-named *application-frame* 'app)))
    ;; We lose the output history, but I think for our purposes that's ok
    (window-clear pane)
    (display-processes *application-frame* pane)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Presentation translators
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Convert a basic :select gesture on a PORT presentation type to a
;;; 'describe presentation' command. This needs to be applicable when
;;; we're in the 'standard' input context for an interactor pane.
(define-presentation-to-command-translator port-select-to-command  ; name
  (t                     ; from-type
   com-describe          ; command-name - maybe com-describe-presentation?
   global-command-table  ; command table containing command
   :gesture :select      ; activate on :select (left-button click)
   ;; :tester ...
   :documentation
   "Invoke the 'describe presentation' command on the selected presentation"
   :pointer-documentation ((object stream) (format stream "Describe ~A" object))
   :menu t               ; command should appear in popped-up menus
   ;; :priority ...
   :echo nil)            ; don't echo the command when it is invoked
  ;; arglist must be a subset (using string-equal) of:
  ;;    (object presentation context-type frame event window x y)
  (object)
  ;; body of translator; returns a list of the arguments to the command
  ;; named by command-name.
  (list object))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Supporting functions; actually 'do stuff'.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Run the application - use (glimpse:glimpse :new-process nil) to run
;;; as anything other than a stand-alone process.
(defun glimpse (&key (new-process t)
		     (process-name nil))
  
  (when (null process-name)
    (setf *glimpse-proc-num* (incf *glimpse-proc-num*))
    (setf process-name (concatenate 'string "Glimpse-" (format nil "~a" *glimpse-proc-num*))))
  
  (flet ((run ()
	      (run-frame-top-level (make-application-frame 'glimpse :pretty-name process-name))))
    (if new-process
	(clim-sys:make-process #'run :name process-name)
      (run))))


;;; Doing some graphing; display ports, grafts and sheets. Turn nodes into
;;; structures so we can pass more information along with them (such as a
;;; presentation for the CLIM UI!)

(defstruct node
  name
  children
  object)
  
;;; Display a graph of the port / graph / sheet (frame?) hierarchy that McCLIM knows
;;; about when this is invoked.


(defmethod display-sheet-hierarchy ((frame glimpse) stream)

  ;; Hrm. When this method is used on any sizable pane hierarchy, the graph goes outside the
  ;; edge of the window. Introduce (scrolling () ...) layout.
  
  ;; Structure is as follows:

  ;; SCREEN            (make-node :name "MAIN SCREEN" :children (list port port2 portn) :object screen)
  ;;   PORT            (make-node :name "PORT NAME" :children (list graft graft2) :object port)
  ;;     GRAFT         (make-node :name "GRAFT" :children (list sheet sheet) :object graft)
  ;;       SHEET       (make-node :name "SHEET" :children (list sheet sheet) :object sheet)
  ;;         SHEET     (make-node :name "SHEET" :object sheet)
  ;;         SHEET     (make-node :name "SHEET" :object sheet)
  ;;       SHEET       (make-node :name "SHEET" :object sheet)
  ;;     GRAFT         (make-node :name "GRAFT" :object graft)
  ;;   PORT            (make-node :name "PORT" :children (list graft) :object port)
  ;;     GRAFT         (make-node :name "GRAFT" :object graft)

  (let ((ports (get-list-of-ports)))
    (if (eq *tree-output-type* :text)
	(format-simple-text-tree ports
				 #'(lambda (node stream)
				     (with-output-as-presentation (stream
								   (node-object node)
								   (type-of (node-object node)))

				       (format *debug-io* "generated presentation for ~a with type ~a~%"
					       (node-object node)
					       (type-of (node-object node)))
				       
				       (write-string (node-name node) stream)))
				 #'node-children
				 :stream stream
				 :indent *tree-output-indent*
				 :indent-increment *tree-indent-increment*)
      (format-graph-from-roots ports
			       #'(lambda (node stream)
				   (write-string (node-name node) stream))
			       #'node-children
			       :stream stream
			       :orientation :vertical
			       :graph-type :tree))))

;;;;
;;;; AIM: to produce output similar to the following:
;;;;
;;;; Given a tree (must be an acyclic tree) such as the following:
;;;;
;;;; screen - port -+-- graft-1
;;;;                 \
;;;;                  - graft-2 -+-- sheet-1
;;;;                             +-- sheet-2
;;;;                             +-- sheet-3
;;;;
;;;; Produce output:-
;;;;
;;;; SCREEN
;;;;     PORT
;;;;         GRAFT-1
;;;;         GRAFT-2
;;;;             SHEET-1
;;;;             SHEET-2
;;;;             SHEET-3
;;;; 
;;;; Need to look at 'format-graph-from-roots' and see if this type could
;;;; be added to that method - better (more CLIM-like) API.
;;;;

(defun format-simple-text-tree (roots display-fn inferiors-fn
        &key stream (indent 2) (indent-increment 2))

  ;; Don't do anything if stream is nil, or if there aren't any roots.

  (unless (or (null stream) (null roots))
    (loop for node in roots
              do (terpri stream)
	      do (indenting-output (stream (list indent :character))
		     (funcall display-fn node stream))
	      do (format-simple-text-tree (funcall inferiors-fn node)
					  display-fn
					  inferiors-fn
					  :stream stream
					  :indent (+ indent
						     indent-increment)
					  :indent-increment indent-increment))))


(defun get-list-of-ports ()
  (let ((nodes ()))
    (dolist (port climi::*all-ports*)
      (setf nodes (push (make-node-for-port port) nodes)))
    (nreverse nodes)))


(defun make-node-for-port (in-port)
  (make-node :name (princ-to-string in-port)
	     :children (if (climi::port-grafts in-port)
			   (let ((child-nodes nil))
			     (dolist (graft (climi::port-grafts in-port))
			       (let ((node (make-node-for-sheet-or-graft graft)))
				 (setf child-nodes (push node child-nodes))))
			     (nreverse child-nodes))
			 nil)
	     :object in-port))


(defun make-node-for-sheet-or-graft (in-sheet)
  (make-node :name (princ-to-string in-sheet)
	     :children (if (sheet-children in-sheet)
			   (let ((child-nodes nil))
			     (dolist (sheet (sheet-children in-sheet))
			       (let ((node (make-node-for-sheet-or-graft sheet)))
				 (setf child-nodes (push node child-nodes))))
			     (nreverse child-nodes))
			 nil)
	     :object in-sheet))

;;; Show processes that Lisp knows about...
(defmethod display-processes ((frame glimpse) stream)
  (let ((processes (get-list-of-processes)))
    (format-simple-text-tree processes
			     #'(lambda (node stream)
				 (with-output-as-presentation (stream
							       (node-object node)
							       (type-of (node-object node)))
				   (write-string (node-name node) stream)))
			     #'node-children
			     :stream stream
			     :indent 0
			     :indent-increment 0)))

(defun get-list-of-processes ()
  (let ((nodes ()))
    (dolist (proc (clim-sys:all-processes))
      (setf nodes (push (make-node :name (princ-to-string proc)
				   :children nil
				   :object proc) nodes)))
    (nreverse nodes)))