(in-package "KPML-I")

;;; File: frame-starter.lisp
;;; January 2000
;;; John Bateman, Bremen.

;;; ACL5.0 for PCs does not allow  a frame to be defined in one thread
;;; and  then  started as  a  window  in  another thread  (i.e.,  when
;;; multiprocessing).  This  means that  a  different  model of  frame
;;; starting   is  required   to   that  found   in  versions   before
;;; KPML3.0.  This  revised model  therefore  has  to  be checked  for
;;; backwards  compatibility with  all the  other lisps.   The present
;;; file provides a macro for defining frame starting functions (which
;;; can  therefore be  more readily  modified if  other  such problems
;;; occur anytime). This also takes the opportunity of providing a lot
;;; of systematization for the frame starts which allows some more 
;;; sophisticated tools for handling all the KPML frames to be built:
;;; see below.

;;; ----------------------------------------------------------------------
;;; Note: the *frame-process-alist* is now no longer an alist, but a 
;;; list of the following structures:
;;; ----------------------------------------------------------------------

(defstruct frame-info
  (name nil)
  (process-idr nil)
  (label nil)
  (id nil)
  (parent nil))

(defun UPDATE-FRAME-INFO (frame-name process-idr &optional (frame-label nil))
  (declare (special *frame-id*))
  (push (make-frame-info 
         :name frame-name
         :process-idr process-idr
         :id (gensym)
         :parent *frame-id*
         :label frame-label)
        *frame-process-alist*))

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

(defvar *frame-label* nil)
(defvar *frame* nil)
(defvar *frame-wait-timeout* 8)

(defmacro DEFINE-KPML-I-FRAME-STARTER 
    (starter-fn frame-class frame-name frame-var 
		&key 
		(args nil)(layout nil)(frameinits nil)(body nil)
		(postbody nil)(offset nil)(optional-reset nil)
                (reset-default nil))
  (let* ((arg-list0 (append args (list (if optional-reset '&optional '&key)
			               (list 'reset reset-default))))
         (arg-list (if optional-reset arg-list0
                     (append arg-list0 
                             (list (list 'frame-tool-label nil))))))
    `(defun ,starter-fn 
            ,arg-list
     ;; if optional-reset then the reset para is not a keyword...
     (let ((*frame-id* clim:*application-frame*))
       (declare (special *frame-id*))
       #-acl3.0
       (when (and reset ,frame-var) (close-a-window ,frame-var))
       (setf ,frame-var nil)
       (when (or reset (not ,frame-var))
         (flet ((do-it ()
	               ,(if offset '(offset-window-if-necessary offset))
	               (let ((frame 
		              (clim:make-application-frame
			          ',frame-class
			        :frame-manager 
			        (clim::find-frame-manager :port (clim::find-port))
			        ,@(if offset
			              (append (list :left (first *current-offsets*) 
				                    :top (second *current-offsets*))
			                      layout)
			            layout))))
		         ,@body
		         ,@(loop for (slot . value) in frameinits
			         collect `(setf (slot-value frame ',slot) ,value))
		         (setf *frame* frame)
		         (if (slot-value frame 'clim-internals::top-level-process)
		             (progn
			       (when (eq (clim::frame-state frame) :shrunk)
			         (clim::note-frame-deiconified 
			          (clim::frame-manager frame) frame))
			       (clim::raise-frame frame))
		           (run-packaged-frame frame (find-package "KPML"))
		           #+acl3.0 ,postbody))))
           (setf *frame* nil)
           #-acl3.0 
           (let ((process (process-run-function ,frame-name #'do-it)))
             (block record-process-start
               (loop for i from 1 to *frame-wait-timeout*
                     do
                     (sleep 1)
                     (when *frame*
                       (update-frame-info *frame* process frame-tool-label)
                       (setf ,frame-var *frame*)
                       (return-from record-process-start T)))
               (kpml::warning "Frame creation timeout for: " ,frame-name))
             ,postbody
             (update-frame-list)
             process)
           #+acl3.0 (do-it)
           T))))))

;;; ----------------------------------------------------------------------
;;; A reoccuring problem is that there are so many little windows
;;; that KPML pops up for various bits of information. Prior to
;;; 3.0 the user had the task of keeping these around if necessary,
;;; and deleting them one-by-one if they were not required. This
;;; task is now helped somewhat... This also brings to Unix window
;;; environments something more reminiscent of the Windows window toolbar
;;; which is very helpful.
;;; ----------------------------------------------------------------------

(defvar *fof* nil)
(defvar *fof-font-size* 7)
(defvar *fof.x* 10)
(defvar *fof.y* 500)
(defvar *frame-tool-activated* T)

;;; ----------------------------------------------------------------------
;;; following mops up some calls to frame starters that happen
;;; without a proper binding environment around them for the
;;; generic frame starters... does not happen with newer windows,
;;; but...
(defvar frame-tool-label "top level")
;;; ----------------------------------------------------------------------

(clim:define-application-frame 
 FRAME-OVERVIEW-FRAME ()
  ((frame-list :initform nil))
  (:menu-bar T)
  (:top-level (clim:default-frame-top-level))
  (:command-definer T)
  (:panes 
   (mouse-doc   :pointer-documentation
	  :foreground  mouse-doc-fg
	  :background  mouse-doc-bg)
   (frames :application
           :incremental-redisplay T
           :foreground inspector-fg
           :background inspector-bg 
           :text-style *sans-serif--bold--7*
           :display-function 'frame-overview-display))
  (:layouts
   (first (clim:vertically () 
			   (:fill frames)
			   #-lispworks (20 mouse-doc)))))

(define-kpml-i-frame-starter 
  FRAME-OVERVIEW
  frame-overview-frame
  "KPML FRAME OVERVIEW TOOL"
  *fof*
  :layout (:left *fof.x* :top *fof.y* :width 150))

;;; ----------------------------------------------------------------------
;;; Display methods...
    ;; KPML 4.0
    ;; ========
    ;; under ACL 5.0 an explicit clim:with-output-recording-options
    ;; makes the frame displayer very unhappy with the arguments
    ;; that Lispworks likes to have. So we just remove it for 
    ;; for the time being under non-Lispworks Lisps. Means we
    ;; we have to mess around unwrapping the body but so it goes...
    ;; just throw it into a macro for now.
;;; ----------------------------------------------------------------------

(defmacro FRAME-OVERVIEW-DISPLAY-BODY ()
  '(let* ((active-frames 
             (loop for f in *frame-process-alist*
                   when (and (frame-info-p f)
                             (mp:process-p (frame-info-process-idr f)))
                   collect f))
             (active-roots 
              (loop for f in active-frames
                    when (loop for f2 in active-frames
                               never (equal (frame-info-name f2)(frame-info-parent f)))
                    collect f)))
        (labels ((ORGANIZE-FROM-ROOT
                  (f-root)
                  (cons f-root 
                        (if f-root
                            (loop for f in active-frames
                                  when (equal (frame-info-parent f) (frame-info-name f-root))
                                  collect (organize-from-root f)))))
                 (NAMES (tree &optional (indent 0))
                        (loop for f in tree
                              if (frame-info-p f) 
                              do 
                              (format stream "~%+")
                              (loop for i from 0 to indent do (format stream " "))
                              (clim:with-output-as-presentation
                                  (stream f 'kpml-frame)
                                (format stream "~A" (kpml-frame-name f)))
                              else
                              do 
                              (clim:with-output-as-presentation
                                  (stream f 'kpml-frame-set)
                                (names f (+ indent 3))))))
          (clim:with-text-size (stream *fof-font-size*)
            (loop for root in active-roots
                  do (names (organize-from-root root)))))))

(defmethod FRAME-OVERVIEW-DISPLAY ((frame frame-overview-frame) stream)
  (with-slots (frame-list) frame
    #+lispworks
    (clim:with-output-recording-options (stream :record T)
      (frame-overview-display-body))
    #-lispworks
    (frame-overview-display-body)
    ))

(defun UPDATE-FRAME-LIST ()
  (when *frame-tool-activated*         ;; 4.0
    (unless (eq *fof* :closing)
      (unless *fof* (frame-overview))
      (when *fof*
	(clim:redisplay-frame-pane *fof* 'frames)))))

;;; ----------------------------------------------------------------------
;;; Presentation types and actions for the frame tool..
;;; ----------------------------------------------------------------------

(clim:define-presentation-type kpml-frame ())
(clim:define-presentation-type kpml-frame-set ())

(clim:define-presentation-action present-kpml-frame
    (kpml-frame nil frame-overview-frame
		:documentation #+lispworks "Deiconify frame"
		               #-lispworks "Raise frame")
  (object)
  #+lispworks(clim:deiconify-frame (frame-info-name object))
  #-lispworks(clim:raise-frame (frame-info-name object))
  )

(clim:define-presentation-action kill-kpml-frame
    (kpml-frame nil frame-overview-frame
                :gesture :menu
                :documentation "Kill frame and window")
  (object)
  (close-a-window (frame-info-name object)))

;;; For Serge...
(clim:define-presentation-action present-kpml-frame-set
    (kpml-frame-set nil frame-overview-frame
			 :documentation "Delete dependent frames")
  (object)
  (labels ((recurse-and-kill (tree)
                             (loop for f in tree
                                   if (frame-info-p f) 
                                   do (close-a-window (frame-info-name f))
                                   else
                                   do (recurse-and-kill f))))
    (recurse-and-kill object)))

;;; ----------------------------------------------------------------------
;;; Present the frames with an intelligible label...
;;; ----------------------------------------------------------------------

(defun KPML-FRAME-NAME (f)
  (with-output-to-string (s)
    (let ((process-name (mp:process-name (frame-info-process-idr f))))
      (format s "~A" (if (stringp process-name)
                                (subseq process-name 5)
                              "DISOWNED"))
      (when (frame-info-label f)
        (format s "  (~A)" (frame-info-label f))))))

