;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Meta Operations
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/meta-operations.lisp
;;; File Creation Date: 02/04/92 10:06:29
;;; Last Modification Time: 12/10/92 15:50:53
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________
;
;                        meta operation sheet
;___________________________________________________________________________

(defmethod select-meta-operation-sheet ((self basic-contact))
  (declare (special *meta-operation-sheet-pool*))
  (popup (get-pool-window *meta-operation-sheet-pool* self)))
 
(defmethod make-meta-operation-sheet ((self basic-contact))
  (while-busy nil
    (make-window
     'shadow-popup-margined-window
     :name :meta-operation-sheet
     :view-of self
     :reactivity-entries '((:part-event))
     :margins 
     `((standard-margins
	:label-options
	(:name :label
	       :inside-border 3
	       :text "Operations")
	:quad-space-options
	(:name :space
	       :thickness 1)))
     :client-window 
     `(text-menu
       :inside-border 15
       :adjust-size? t
       :reactivity-entries
       ((:part-event (call :pass-part-event)
		     (call :eval (funcall *part-value* (view-of *self*)))))
       :parts 
       ,(sorted-meta-operation-sheet-entries self)))))

(defmethod sorted-meta-operation-sheet-entries ((self basic-contact))
  (sort (copy-list (meta-operation-sheet-entries self))
	#'string<
	:key #'(lambda (entry) (getf entry :text))))

;___________________________________________________________________________
;
;                    meta operation sheet entries
;___________________________________________________________________________

(defmethod meta-operation-sheet-entries ((self basic-contact))
  '((:view-of refresh-window
     :text "Refresh"
     :action-docu "Refresh window")
    (:view-of move-window
     :text "Move"
     :action-docu "Move window")
    (:view-of resize-window
     :text "Resize"
     :action-docu "Resize window")
    (:view-of destroy
     :text "Destroy"
     :action-docu "Destroy window")
    (:view-of reparent-window-with-mouse
     :text "New Parent"
     :action-docu "Select new parent for window")
    (:view-of copy-and-move-window
     :text "Copy"
     :action-docu "Create copy")
    (:view-of copy-and-reparent-window
     :text "Copy to New Parent"
     :action-docu "Create copy and select new parent for it")
    (:view-of select-meta-property-sheet
     :text "Properties"
     :action-docu "Change properties")
    (:view-of generate-and-write-code
     :text "Save"
     :action-docu "Generate and save code")))

(defmethod meta-operation-sheet-entries :around ((self contact))
  (append
   (call-next-method)
   '((:view-of totop-window
      :text "Totop"
      :action-docu "Put window on top")
     (:view-of tobottom-window
      :text "Tobottom"
      :action-docu "Put window to bottom"))
   (unless (typep self 'popup-part-connection)
     '((:view-of add-popup-part
	:text "Add Popup"
        :action-docu "Add Popup")))
   (unless (typep self 'window-icon-mixin)
     '((:view-of add-window-icon
        :text "Add Window Icon"
        :action-docu "Add Window Icon")))))

(defmethod meta-operation-sheet-entries :around ((self composite))
  (append
   (call-next-method)
   (unless (or (typep self 'margined-window)
	       (typep self 'container-window))
     '((:view-of select-new-part-from-palette 
	:text "Create Part"
	:action-docu "Create new part")))))

(defmethod meta-operation-sheet-entries :around ((self uniform-part-intel))
  (append
   (call-next-method)
   '((:view-of select-meta-add-part-sheet
      :text "Add Parts"
      :action-docu "Add new parts"))))

(defmethod meta-operation-sheet-entries :around ((self window-icon-mixin))
  (append
   (call-next-method)
   '((:view-of expand
      :text "Expand"
      :action-docu "Expand corresponding icon to window")
     (:view-of shrink
      :text "Shrink"
      :action-docu "Shrink window to icon")
     (:view-of identify-window-icon-with-mouse
      :text "Change Window Icon"
      :action-docu "Change window icon"))))

(defmethod meta-operation-sheet-entries :around ((self adjustable-window))
  (append
   (call-next-method)
   '((:view-of adjust-window-size
      :text "Adjust Size"
      :action-docu "Adjust window size"))))

(defmethod meta-operation-sheet-entries :around ((self layouted-window))
  (append
   (call-next-method)
   '((:view-of change-layout
      :text "Update Layout"
      :action-docu "Update window layout")
     (:view-of select-layout-meta-sheet-for
      :text "Layout"
      :action-docu "Change window layout"))))

(defmethod meta-operation-sheet-entries :around ((self margined-window))
  (append
   (call-next-method)
   '((:view-of select-client-window-from-palette
      :text "Change Client"
      :action-docu "Change client window"))))

(defmethod meta-operation-sheet-entries :around ((self container-window))
  (append
   (call-next-method)
   '((:view-of select-client-window-from-palette
      :text "Change Client"
      :action-docu "Change client window"))))

(defmethod meta-operation-sheet-entries :around ((self popup-part-connection))
  (append
   (call-next-method)
   '((:view-of select-from-popup-part
      :text "Select From Popup"
      :action-docu "Select from popup part")
     (:view-of identify-popup-part-with-mouse
      :text "Change Popup"
      :action-docu "Change popup part")
     (:view-of show-popup-part
      :text "Show Popup"
      :action-docu "Show popup part")
     (:view-of destroy-popup-part
      :text "Destroy Popup"
      :action-docu "Destroy popup part"))))

(defmethod meta-operation-sheet-entries :around ((self interaction-window))
  (append
   (call-next-method)
   '((:view-of select-meta-reactivity-sheet
      :text "Reactivity"
      :action-docu "Change reactivity"))
   (when (reactivity-entry self :read-event)
     '((:view-of read-from-application
	:text "Read From Application"
	:action-docu "Read from application")))
   (when (reactivity-entry self :write-event)
     '((:view-of write-to-application
	:text "Write To Application"
	:action-docu "Write to application")))))

(defmethod meta-operation-sheet-entries :around ((self timer-mixin))
  (append
   (call-next-method)
   '((:view-of select-meta-timer-sheet
      :text "Timer"
      :action-docu "Specify timer"))))

(defmethod meta-prompt-text ((self text-dispel))
  (let ((new-text (prompt "Enter new text:" :default (text self))))
    (when new-text
      (setf (text self) new-text))))

(defmethod meta-operation-sheet-entries :around ((self text-dispel))
  (append
   (call-next-method)
   '((:view-of meta-prompt-text
      :text "Change Text"
      :action-docu "Change text"))))

(defmethod meta-operation-sheet-entries :around ((self bitmap-dispel))
  (append
   (call-next-method)
   '((:view-of edit-bitmap
      :text "Edit Bitmap"
      :action-docu "Invoke bitmap editor")
     (:view-of reload-bitmap
      :text "Reload Bitmap"
      :action-docu "Reload bitmap file")
     (:view-of select-meta-bitmap-menu
      :text "Change Bitmap"
      :action-docu "Change bitmap"))))
