;;; Simple sheet hierarchy viewer

(in-package :cl-user)


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

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

(in-package :glimpse)


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

(define-application-frame glimpse ()
  ()
  (:panes
   (app :application
	:display-time t
	:end-of-line-action :allow
	:height 500 :width 600)
   (int :interactor
	:height 75  :width 600))
  (:layouts
   (default (vertically () app int))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Command definitions
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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)))
    (display-sheet-hierarchy *application-frame* pane)))


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

;;; Run the application - use (glimpse:glimpse :new-process t) to run
;;; as a stand-alone process.
(defun glimpse (&key (new-process nil)
		     (process-name "Glimpse"))
  (flet ((run ()
	      (run-frame-top-level (make-application-frame 'glimpse))))
    (if new-process
	(clim-sys:make-process #'run :name process-name)
      (run))))


;;; Doing some graphing; display ports, grafts and sheets.

(defun make-node (&key name children)
  (if (null children)
      (list name)
    (list* name children)))

(defun node-name (node)
  (car node))

(defun node-children (node)
  (cdr node))


;;; 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))
  ;;   PORT            (make-node :name "PORT NAME" :children (list graft graft2))
  ;;     GRAFT         (make-node :name "GRAFT" :children (list sheet sheet))
  ;;       SHEET       (make-node :name "SHEET" :children (list sheet sheet))
  ;;         SHEET     (make-node :name "SHEET")
  ;;         SHEET     (make-node :name "SHEET")
  ;;       SHEET       (make-node :name "SHEET")
  ;;     GRAFT         (make-node :name "GRAFT")
  ;;   PORT            (make-node :name "PORT" :children (list graft))
  ;;     GRAFT         (make-node :name "GRAFT")

  (let ((ports (get-list-of-ports)))
    (format-simple-text-tree ports
			     #'(lambda (node stream)
				 (write-string (node-name node) stream))
			     #'node-children
			     :stream stream)))

;;; Uncomment the following and comment out 'format-simple-text-tree' if you want
;;; a 'pretty graph'.
#||
    (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 0) (indent-increment 4))

  ;; 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 (progn  ; using 'indent' instead of 'indnt' breaks it!
		   (terpri stream)
		   (indenting-output (stream (list indent :character))
		     (funcall display-fn node stream))
		   (format-simple-text-tree (funcall inferiors-fn node)
					    display-fn
					    inferiors-fn
					    :stream stream
					    :indent (+ indent
						       indent-increment))))))


;;; Must be able to do this in a nicer manner... no time now.
(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-graft graft)))
				 (setf child-nodes (push node child-nodes))))
			     (nreverse child-nodes))
			 nil)))


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


(defun make-node-for-sheet (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 sheet)))
				 (setf child-nodes (push node child-nodes))))
			     (nreverse child-nodes))
			 nil)))