;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: System Menu
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/system-menu.lisp
;;; File Creation Date: 10/06/92 11:11:32
;;; Last Modification Time: 12/14/92 09:46:40
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;; System Menu:
;;
;; It contains general commands, such as "gc" or "quit event loop",
;; and tool-specific commands, such as open a new browser.
;; The entry "tools" pops up the tools menu.
;; The system menu may be extended by the following functions:
;;
;;   (add-system-menu-entry ...initargs...)
;;   
;;   e.g., (add-system-menu-entry :name :foo 
;;                                :text "foo" 
;;                                :action '(call :eval (foo))
;;                                :action-docu "Call foo")
;;
;;   The :name attribute should always be specified and unique.
;;
;;   (add-system-menu-entries ...entries...)
;;
;; Tools Menu:
;;
;; It contains commands for loading tools, e.g. the identifier or the metaystem
;; The tools menu may be extended by the following functions:
;;
;;   (add-tools-menu-entry ...initargs...)
;;   
;;   e.g., (add-tools-menu-entry :name :foo 
;;                               :text "foo" 
;;                               :action '(call :eval (load "foo"))
;;                               :action-docu "Load foo")
;;
;;   The :name attribute should always be specified and unique.
;;
;;   (add-tools-menu-entries ...entries...)

(proclaim '(special *toplevel* *display*))

(defvar *system-menu* nil)

(defvar *tools-menu* nil)

(defvar *system-menu-entries*)

(setq *system-menu-entries*
    '((:name :tools
       :text "tools"
       :action (call :eval (select-from-tools-menu))
       :action "Select tool to be loaded")
      (:name :gc
       :text "garbage collection"
       :action (call :eval (while-busy () (user::gc) (user::gc t)))
       :action-docu "Invoke garbage collection")
      (:name :stop-loop
       :text "stop event loop"
       :action ((call :eval (hide *system-menu*))
		(call :eval (process-all-events (contact-display *self*)))
		(call :eval (stop-event-loop)))
       :action-docu "Stop event loop")
      (:name :quit
       :text "quit"
       :action (call :eval (when (confirm "Close toplevel display?")
			     (close-toplevel-display)))
       :action-docu "Close display")))

(defvar *tools-menu-entries*)

(setq *tools-menu-entries*
    '((:name :window-identifier
       :text "window identifier"
       :action (call :eval
		     (while-busy ()
		       (load (system-pathname :xit-utilities "identifier"))))
       :action-docu "Load window identifier")
      (:name :mouse-docu
       :text "mouse documentation"
       :action (call :eval
		(while-busy ()
		  (load (system-pathname :xit-utilities "mouse-documentation"))))
       :action-docu "Load mouse documentation line")
      (:name :examples
       :text "examples"
       :action (call :eval
		(while-busy ()
		  (pmds::load-system :xit-examples)))
       :action-docu "Load XIT examples")
      (:name :resource-sheet
       :text "resource sheet"
       :action (call :eval
		(while-busy ()
		  (load (system-pathname :xit-utilities "make-resource-sheet"))))
       :action-docu "Load resource property sheet")
      (:name :xam
       :text "meta system"
       :action (call :eval
		(while-busy ()
		  (load (system-pathname :xit "../xam/load-xam"))))
       :action-docu "Load user interface meta system")
      (:name :xact
       :text "ui construction kit"
       :action (call :eval
		(while-busy ()
		  (load (system-pathname :xit "../xact/load-xact"))))
       :action-docu "Load user interface meta system")
      (:name :xbrowse
       :text "browers"
       :action (call :eval
		(while-busy ()
		  ;(load (system-pathname :xit "../../xbrowse/load-xbrowse"))
		 (load "/usr/local/lisp/xbrowse/load-xbrowse")))
       :action-docu "Load system XBROWSE")
      (:name :xtract
       :text "tracers"
       :action (call :eval
		(while-busy ()
		  ;(load (system-pathname :xit "../../xtract/load-xtract"))
		 (load "/usr/local/lisp/xtract/load-xtract")))
       :action-docu "Load system XTRACT")
      ))

(defun system-menu-exists-p ()
  (and *system-menu* (not (destroyed-p *system-menu*))))

(defun tools-menu-exists-p ()
  (and *tools-menu* (not (destroyed-p *tools-menu*))))

(defun system-menu ()
  (when (system-menu-exists-p)
    (client-window (client-window *system-menu*))))

(defun tools-menu ()
  (when (tools-menu-exists-p)
    (client-window (client-window *tools-menu*))))

(defun remove-system-menu-entry (name)
  (setq *system-menu-entries*
      (remove name *system-menu-entries*
	      :key #'(lambda (entry) (getf entry :name))
	      :test #'eq))
  (when (system-menu-exists-p)
    (delete-part (system-menu) name)))

(defun remove-tools-menu-entry (name)
  (setq *tools-menu-entries*
      (remove name *tools-menu-entries*
	      :key #'(lambda (entry) (getf entry :name))
	      :test #'eq))
  (when (tools-menu-exists-p)
    (delete-part (tools-menu) name)))

(defun add-system-menu-part (&rest initargs)
  (let* ((system-menu (system-menu))
	 (entry (part *system-menu* (getf initargs :name))))
    (when entry (destroy entry))
    (apply #'add-part system-menu initargs)))

(defun add-tools-menu-part (&rest initargs)
  (let* ((tools-menu (tools-menu))
	 (entry (part tools-menu (getf initargs :name))))
    (when entry (destroy entry))
    (apply #'add-part tools-menu initargs)))

(defun add-system-menu-entry (&rest initargs)
  (remove-system-menu-entry (getf initargs :name))
  (setq *system-menu-entries*
      (append *system-menu-entries* (list initargs)))
  (when (system-menu-exists-p)
    (apply #'add-system-menu-part initargs)))

(defun add-tools-menu-entry (&rest initargs)
  (remove-tools-menu-entry (getf initargs :name))
  (setq *tools-menu-entries*
      (append *tools-menu-entries* (list initargs)))
  (when (tools-menu-exists-p)
    (apply #'add-tools-menu-part initargs)))

(defun add-system-menu-entries (&rest entries)
  (dolist (entry entries)
    (apply #'add-system-menu-entry entry)))

(defun add-tools-menu-entries (&rest entries)
  (dolist (entry entries)
    (apply #'add-tools-menu-entry entry)))

(defun make-system-menu ()
  (while-busy ()
    (when (system-menu-exists-p)
      (destroy *system-menu*))
    (setq *system-menu*
	(make-gio 'shadow-borders-popup-container
		  :name :system-menu
		  :client-window
		  `(margined-window
		    :margins
		    ((standard-margins
		      :label-options (:name :label
					    :inside-border 3
					    :text "System Menu")
		      :quad-space-options (:name :space
						 :thickness 1)))
		    :client-window (text-menu
				    :adjust-size? t
				    :reactivity-entries
				    ((:part-event (call :pass-part-event)))
				    :parts ,*system-menu-entries*))))))

(defun make-tools-menu ()
  (while-busy ()
    (when (tools-menu-exists-p)
      (destroy *tools-menu*))
    (setq *tools-menu*
	(make-gio 'shadow-borders-popup-container
		  :name :tools-menu
		  :client-window
		  `(margined-window
		    :margins
		    ((standard-margins
		      :label-options (:name :label
					    :inside-border 3
					    :text "Tools Menu")
		      :quad-space-options (:name :space
						 :thickness 1)))
		    :client-window (text-menu
				    :adjust-size? t
				    :reactivity-entries
				    ((:part-event (call :pass-part-event)))
				    :parts ,*tools-menu-entries*))))))

(defun select-from-system-menu ()
  (unless (system-menu-exists-p)
    (make-system-menu))
  (popup *system-menu*))

(defun select-from-tools-menu ()
  (unless (tools-menu-exists-p)
    (make-tools-menu))
  (popup *tools-menu*))

(defun connect-system-menu (&optional (toplevel *toplevel*))
  (declare (special *toplevel*))
  (change-reactivity toplevel
		     :menu "System menu"
		     '(call :eval (select-from-system-menu))))

(if (and (boundp '*display*) *display*
	 (boundp '*toplevel*) *toplevel*)
    (connect-system-menu *toplevel*)
  (add-open-toplevel-hook 'connect-system-menu))
