;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Add Part
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/add-part-meta.lisp
;;; File Creation Date: 02/04/92 13:06:10
;;; Last Modification Time: 07/30/92 14:10:22
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________
;
;                           add part sheet
;___________________________________________________________________________

(defmethod select-meta-add-part-sheet ((self uniform-part-intel))
  (declare (special *meta-add-part-sheet-pool*))
  (popup (get-pool-window *meta-add-part-sheet-pool* self)))

(defmethod new-menu-part ((self uniform-part-intel) &rest init-list)
  (apply #'add-part self 
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod new-menu-part ((self switch) &rest init-list)
  (apply #'add-part self
	 ;; button events reserved for switching!
	 ;;:reactivity-entries '((:metasystem))
	 init-list))

(defmethod make-meta-add-part-sheet ((self uniform-part-intel)) 
  (create-meta-property-sheet
     self
     :name :meta-add-part-sheet
     :reactivity-entries
     '((:read-event
	(call :eval
	      (setf (title *self*)
		  (concatenate 'string "Add part to "
		     (convert-to-string
		      (class-name (class-of (view-of *self*)))))))))
						  
     :property-sheet-reactivity
     '((:double-right-button
	"Generate new part"
	(call :eval
	      (let ((view-of (view-of *self*)))
		(apply #'new-menu-part
		       view-of
		       (append
			(mapcan #'(lambda (entry)
				    (list (contact-name entry)
					  (value entry)))
				(parts *self*))
			(add-part-init-args view-of)))))
	(call :read)))
     :parts (meta-add-part-sheet-entries self (part-class self))))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel) part-class)
  (declare (ignore part-class))
  `((:class text-property-field
     :name :class
     :label "class" 
     :read-function part-class
     :read-transformation (lambda (value) 
			       (string-downcase (write-to-string value)))
     :reactivity-entries ((:part-event))) ; don't call :write
    (:class text-property-field
     :name :name
     :label "name"
     :read-function  ;;(lambda (ignore) (genstring ":item"))
     (lambda (view-of)
       (string-downcase (genstring (format nil ":~A" (class-name (find-class (part-class view-of)))))))
     :reactivity-entries ((:part-event)))
    (:class text-property-field
     :name :view-of
     :label "view-of"
     ;;:read-function (lambda (ignore) "nil")
     :reactivity-entries ((:part-event)
			  (:read-event)))))

(defmethod meta-add-part-sheet-entries :around ((self basic-menu) part-class)
  (declare (ignore part-class))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :action
      :label "action"
      ;;:read-function (lambda (ignore) "nil")
      :reactivity-entries ((:part-event)
			   (:read-event)))
     (:class text-property-field
      :name :action-docu
      :label "action-docu"
      ;;:read-function (lambda (ignore) "Select")
      :write-transformation string
      :reactivity-entries ((:part-event)
			   (:read-event))))))

(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'text-dispel)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :text
      :label "text"
      :read-function
      (lambda (view-of)
	(format nil "item~D" (1+ (length (parts view-of)))))
      :write-transformation string
      :reactivity-entries ((:part-event))))))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'bitmap-dispel)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :bitmap
      :label "bitmap"
      ;;:read-function (lambda (ignore) "nil")
      :write-transformation string
      :reactivity-entries ((:part-event)
			   (:read-event))))))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'labelled-choice-box)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :text
      :label "text"
      :read-function
      (lambda (view-of)
	(format nil "item~D" (1+ (length (parts view-of)))))
      :write-transformation string
      :reactivity-entries ((:part-event))))))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'labelled-radio-choice-box)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :text
      :label "text"
      :read-function
      (lambda (view-of)
	(format nil "item~D" (1+ (length (parts view-of)))))
      :write-transformation string
      :reactivity-entries ((:part-event))))))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'property-field)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :label
      :label "label"
      :read-function
      (lambda (view-of)
	(string-downcase (format nil "item~D" (1+ (length (parts view-of))))))
      :write-transformation string
      :reactivity-entries ((:part-event)))
     (:class text-property-field
      :name :read-function
      :label "read-function"
      :reactivity-entries ((:part-event)
			   (:read-event)))
     (:class text-property-field
      :name :write-function
      :label "write-function"
      :reactivity-entries ((:part-event)
			   (:read-event)))
     )))
     
(defmethod meta-add-part-sheet-entries ((self uniform-part-intel)
					(part-class (eql 'text-property-field)))
  (append
   (call-next-method)
   `((:class text-property-field
      :name :label
      :label "label"
      :read-function
      (lambda (view-of)
	(format nil "item~D" (1+ (length (parts view-of)))))
      :write-transformation string
      :reactivity-entries ((:part-event)))
     (:class text-property-field
      :name :read-function
      :label "read-function"
      :reactivity-entries ((:part-event)
			   (:read-event)))
     (:class text-property-field
      :name :write-function
      :label "write-function"
      :reactivity-entries ((:part-event)
			   (:read-event)))
     )))

(defmethod add-part-init-args ((self uniform-part-intel))
  nil)

(defmethod add-part-init-args ((self property-sheet))
  (append
   (call-next-method)
   '(:read-initially? nil))) ;; no view-of set

