;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Metasystem
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/meta-system.lisp
;;; File Creation Date: 02/04/92 08:54:57
;;; Last Modification Time: 09/17/92 09:36:11
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________

(in-package :xit)
		    
;___________________________________________________________________________
;
;                               meta menu
;___________________________________________________________________________

(defmethod select-meta-system ((self basic-contact))
  (declare (special *meta-sheet-pool*))
  (popup (get-pool-window *meta-sheet-pool* self)))

(defmethod meta-sheet-pool-internal-key-transformation ((self basic-contact))
  :no-parts)

(defmethod meta-sheet-pool-internal-key-transformation ((self composite))
  :parts)

(defmethod make-meta-sheet ((self basic-contact))
  (create-meta-property-sheet
   self
   :name :meta-sheet
   :reactivity-entries
   '((:read-event
      (call :eval
	    (setf (title *self*)
		;(concatenate 'string "Metasystem for "
		     ;(convert-to-string
		      ;(class-name (class-of (view-of *self*)))))
		"Meta Menu"
		))))
   :parts
   (remove nil
	   `(;;,(window-property-sheet-entry self)
	     ;;,(parent-property-sheet-entry self)
	     ,(class-property-sheet-entry self)
	     ,(name-property-sheet-entry self)
	     ,(parent-class-property-sheet-entry self)
	     ,(parent-name-property-sheet-entry self)
	     ,(part-number-property-sheet-entry self)
	     (:class dispel
	      :width 250 :height 2 :adjust-size? nil
	      :background "black")
	     (:class text-menu
	      :reactivity-entries ,(meta-sheet-menu-reactivity-entries self)
	      :parts ,(remove nil (meta-sheet-entries self)))))))

(defmethod meta-sheet-menu-reactivity-entries ((self basic-contact))
  '((:read-event
     (call :eval
	   (let ((view-of (view-of *self*))
		 (meta-for-parent (part *self* :meta-for-parent)))
	     (setf (contact-sensitive meta-for-parent)
		 (if (eq (toplevel-window view-of) view-of)
		     :off :on)))))))

(defmethod meta-sheet-menu-reactivity-entries ((self composite))
  '((:read-event
     (call :eval
	   (let ((view-of (view-of *self*))
		 (meta-for-parent (part *self* :meta-for-parent))
		 (meta-for-part (part *self* :meta-for-part)))
	     (setf (contact-sensitive meta-for-parent)
		 (if (eq (toplevel-window view-of) view-of)
		     :off :on))
	     (setf (contact-sensitive meta-for-part)
		   (if (composite-children view-of)
		       :on :off)))))))

(defmethod meta-sheet-entries ((self basic-contact))
  `((:text "Metasystem for parent"
     :name :meta-for-parent
     :action
     ((call :self hide-popup-parent)
      (call :eval (select-meta-system
		   (contact-parent (view-of *self*)))))
     :action-docu "Invoke metasystem for parent")
    (:text "Properties"
     :action
     ((call :self hide-popup-parent)
      (call :view-of select-meta-property-sheet))
     :action-docu "Change properties")
    (:text "Operations"
     :action
     ((call :self hide-popup-parent)
      (call :view-of select-meta-operation-sheet))
     :action-docu "Perform operations")))

(defmethod meta-sheet-entries :around ((self composite))
  (let ((entries (call-next-method)))
    (list* (first entries)
	   '(:text "Metasystem for part"
	     :name :meta-for-part
	     :action
	     ((call :self hide-popup-parent)
	      (call :view-of select-meta-system-for-part))
	     :action-docu "Invoke metasystem for a part")
	   (rest entries))))

(defmethod select-meta-system-for-part ((self composite))
  (while-busy nil
   (let ((menu (make-window 'shadow-popup-text-menu
			   :part-class 'window-viewing-text-dispel
			   :layouter '(multiline-distance-layouter
				       :items-per-line 20
				       :line-offset 150)
			   :destroy-after? t)))
    (select-from-objects menu (composite-children self)
       :part-init-list '(:action (call :view-of select-meta-system)
			 :action-docu "Invoke metasystem for this part")))))
  
;___________________________________________________________________________
;
;                         meta sheets
;___________________________________________________________________________

(defmethod make-meta-sheet-named (key)
  ) ; to be specialized
