;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Meta Properties
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/meta-properties.lisp
;;; File Creation Date: 02/04/92 10:04:52
;;; Last Modification Time: 12/11/92 14:34:18
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________
;
;                        meta property sheet
;___________________________________________________________________________

(defmethod select-meta-property-sheet ((self basic-contact))
  (declare (special *meta-property-sheet-pool*))
  (popup (get-pool-window *meta-property-sheet-pool* self)))
      
(defmethod make-meta-property-sheet ((self basic-contact)) 
  (create-meta-property-sheet
	 self
	 :name :meta-property-sheet
	 :reactivity-entries
	 '((:read-event
	    (call :eval
		  (setf (title *self*)
		      ;(concatenate 'string "Properties for "
		        ;(convert-to-string
			 ;(class-name (class-of (view-of *self*)))))
		      "Properties"
		      ))))
	 :parts 
	 (remove nil
		 (list
		 ;(class-name-property-sheet-entry self)
		  (class-property-sheet-entry self)
		  (name-property-sheet-entry self)
		 ;(x-y-width-height-property-sheet-entry self)
		  (x-property-sheet-entry self)
		  (y-property-sheet-entry self)
		  (width-property-sheet-entry self)
		  (height-property-sheet-entry self)
		  (border-width-property-sheet-entry self)
		  (inside-border-property-sheet-entry self)
		  (display-position-property-sheet-entry self)
		  (adjust-size?-property-sheet-entry self)
		  (layout-property-sheet-entry self)
		  (margin-thickness-property-sheet-entry self)
		  (margin-location-property-sheet-entry self)
		  (background-property-sheet-entry self)
		  (foreground-property-sheet-entry self)
		  (text-property-sheet-entry self)
		  (font-property-sheet-entry self)
		  (bitmap-property-sheet-entry self)
		  (title-property-sheet-entry self)
		  (state-property-sheet-entry self)
		  (selected-property-sheet-entry self)
		  (sensitive-property-sheet-entry self)
		  (mouse-feedback-property-sheet-entry self)
		  (part-class-property-sheet-entry self)
		  (part-mouse-feedback-property-sheet-entry self)
		  (part-font-property-sheet-entry self)
		 ;(mouse-documentation-property-sheet-entry self)
		 ;(compute-mouse-documentation-property-sheet-entry self)
		  (popup-position-property-sheet-entry self)
		  (hide-on-mouse-exit?-property-sheet-entry self)
		  (hide-on-part-event?-property-sheet-entry self)
		  (destroy-after?-property-sheet-entry self)
		  (popup-part-connection-property-sheet-entry self)
		  (action-property-sheet-entry self)
		  (action-docu-property-sheet-entry self)
		  (action-mode-property-sheet-entry self)
		  (editable?-property-sheet-entry self)
		  (reactivity-property-sheet-entry self)
		  (read-function-property-sheet-entry self)
		  (write-function-property-sheet-entry self)
		  (read-transformation-property-sheet-entry self)
		  (write-transformation-property-sheet-entry self)
		  (view-of-property-sheet-entry self)))))

;___________________________________________________________________________
;
;                       meta property sheet entries
;___________________________________________________________________________

(defmethod window-property-sheet-entry ((self basic-contact))
  `(:label "window"
    :read-function identity
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel)))

(defmethod parent-property-sheet-entry ((self basic-contact))
  `(:label "parent" 
    :read-function contact-parent
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel
     :reactivity-entries ((:copy-property
			   (call :self copy-property 'identity
				 :writer 'contact-parent
				 :window-type 'composite
				 :mouse-documentation "Identify parent"))))))

(defmethod class-name-property-sheet-entry ((self basic-contact))
  `(:class text-property-line-sheet
    :inside-border 0
    :parts ((:label "class" 
	     :read-function (lambda (window) (class-name (class-of window)))
	     :read-transformation (lambda (value) 
				    (string-downcase (write-to-string value)))
	     :value-part 
	     (:class non-active-text-dispel))
	    (:label "name"
	     :read-function contact-name
	     :read-transformation (lambda (value) 
				    (string-downcase (write-to-string value)))
	     :write-function (lambda (view-of name)
			       (setf (slot-value view-of 'name) name))))))
	    
(defmethod class-property-sheet-entry ((self basic-contact))
  `(:label "class" 
    :read-function (lambda (view-of) (class-name (class-of view-of)))
    :read-transformation (lambda (value) 
			   (string-downcase (write-to-string value)))
    :value-part 
    (:class non-active-text-dispel)))

(defmethod name-property-sheet-entry ((self basic-contact))
  `(:class text-property-field
    :label "name"
    :read-function contact-name
    :read-transformation (lambda (value) 
                              (string-downcase (write-to-string value)))
    :write-function (lambda (view-of name)
			 (setf (slot-value view-of 'name) name))))

(defmethod parent-class-property-sheet-entry ((self basic-contact))
  `(:label "parent class" 
    :read-function (lambda (view-of)
			(with-slots (parent) view-of
			  (when parent (class-name (class-of parent)))))
    :read-transformation (lambda (value) 
                              (string-downcase (write-to-string value)))
    :value-part 
    (:class non-active-text-dispel
     :font (:face :italic))))
     
(defmethod parent-name-property-sheet-entry ((self basic-contact))
  `(:label "parent name" 
    :read-function (lambda (view-of) 
			(with-slots (parent) view-of
			  (when parent (contact-name parent))))
    :read-transformation (lambda (value) 
                              (string-downcase (write-to-string value)))
    :value-part 
    (:class non-active-text-dispel
     :font (:face :italic))))
     
(defmethod part-number-property-sheet-entry (ignore)
  nil)

(defmethod part-number-property-sheet-entry ((self composite))
  `(:label "number of parts" 
    :read-function (lambda (view-of) 
			(length (composite-children view-of)))
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel)))

(defmethod x-y-width-height-property-sheet-entry ((self basic-contact))
  '(:class text-property-line-sheet
    :inside-border 0
    :parts ((:label "x"
	     :read-function contact-x
	     :write-function change-window-x)
	    (:label "y"
	     :read-function contact-y
	     :write-function change-window-y)
	    (:label "width"
	     :read-function contact-width
	     :write-function change-window-width)
	    (:label "height"
	     :read-function contact-height
	     :write-function change-window-heigth))))


(defmethod x-property-sheet-entry ((self basic-contact))
  `(:class text-property-field
    :label "x"
    :read-function contact-x
    :write-function change-window-x
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'contact-x
				 :write-function 'change-window-x
				 :mouse-documentation
				 "Identify x coordinate"))))))

(defmethod y-property-sheet-entry ((self basic-contact))
  `(:class text-property-field
    :label "y"
    :read-function contact-y
    :write-function change-window-y
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'contact-y
				 :write-function 'change-window-y
				 :mouse-documentation
				 "Identify y coordinate"))))))

(defmethod width-property-sheet-entry ((self basic-contact))
  `(:class text-property-field
    :label "width"
    :read-function contact-width
    :write-function change-window-width
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'contact-width
				 :write-function 'change-window-width
				 :mouse-documentation "Identify width"))))))

(defmethod height-property-sheet-entry ((self basic-contact))
  `(:class text-property-field
    :label "height"
    :read-function contact-height
    :write-function change-window-height
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'contact-height
				 :write-function 'change-window-height
				 :mouse-documentation "Identify height"))))))

 (defmethod border-width-property-sheet-entry ((self basic-contact))
  `(:label "border-width"
    :read-function contact-border-width
    :write-function change-window-border-width
    :value-part
    (:class text-switch
     :border-width 1
     :inside-border 2
     :reactivity-entries
     ((:single-left-button
       "Increment border width"
       (call :self switch-forward))
      (:single-right-button
       "Decrement border width"
       (call :self switch-backward))
      (:copy-property
       (call :self copy-property 'contact-border-width
	     :write-function 'change-window-border-width
	     :mouse-documentation "Identify border-width")))
     :parts ((:view-of 0 :text "0")
             (:view-of 1 :text "1")
             (:view-of 2 :text "2")
             (:view-of 3 :text "3")
             (:view-of 4 :text "4")
             (:view-of 5 :text "5")
             (:view-of 6 :text "6")
             (:view-of 7 :text "7")
             (:view-of 8 :text "8")
             (:view-of 9 :text "9")
             (:view-of 10 :text "10")))))

(defmethod background-property-sheet-entry (ignore)
  nil)

(defmethod background-property-sheet-entry ((self contact))
  (declare (special *white-pixel* *black-pixel*))
  `(:label "background"
    :read-function contact-background
    :write-function change-window-background
    :value-part 
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :reactivity-entries ((:menu "Color sheet"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-color-sheet
				 :color-reader :background))
			  (:copy-property
			   (call :self copy-property 'contact-background
				 :write-function 'change-window-background
				 :window-type 'contact
				 :mouse-documentation "Identify background")))
     :parts ((:view-of :parent-relative
              :action-docu "Select parent-relative Background"
	      :text "parent-relative")
             (:view-of ,*white-pixel*
              :action-docu "Select white Background"
	      :text "white")
             (:view-of ,*black-pixel*
              :action-docu "Select black Background"
	      :text "black")))))
                       
(defmethod foreground-property-sheet-entry (ignore)
  nil)

(defmethod foreground-property-sheet-entry ((self foreground-color-mixin)) 
  (declare (special *white-pixel* *black-pixel*))
  `(:label "foreground"
    :read-function foreground
    :value-part 
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :reactivity-entries ((:menu "Color sheet"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-color-sheet
				 :color-reader :foreground))
			  (:copy-property
			   (call :self copy-property 'foreground
				 :window-type 'foreground-color-mixin
				 :mouse-documentation "Identify foreground")))
     :parts ((:view-of ,*white-pixel*
              :action-docu "Select white Foreground"
              :text "white")
             (:view-of ,*black-pixel*
              :action-docu "Select black Foreground"
              :text "black")))))

(defmethod inside-border-property-sheet-entry (ignore)
  nil)

(defmethod inside-border-property-sheet-entry ((self basic-window))
  `(:class text-property-field
    :label "inside-border"
    :read-function inside-border
    :read-transformation write-to-string
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'inside-border
				 :window-type 'basic-window
				 :mouse-documentation
				 "Identify inside-border"))))))

(defmethod adjust-size?-property-sheet-entry (ignore)
  nil)

(defmethod adjust-size?-property-sheet-entry ((self adjustable-window))
  `(:label "adjust-size?"
    :name :adjust-size?
    :read-function adjust-size?
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "do adjust window size")
             (:view-of :no
	      :text "no"
	      :action-docu "do not adjust window size")))))
                       
(defmethod state-property-sheet-entry ((self basic-contact))
  `(:label "state"
    :read-function contact-state
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :withdrawn 
              :action-docu "Select withdrawn state"
              :text "withdrawn")
             (:view-of :managed 
              :action-docu "Select managed state"
              :text "managed")
             (:view-of :mapped 
              :action-docu "Select mapped state"
              :text "mapped")))))

(defmethod sensitive-property-sheet-entry (ignore)
  nil)

(defmethod sensitive-property-sheet-entry ((self basic-contact))
  `(:label "sensitive?"
    :read-function contact-sensitive
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :on
	      :text "on"
	      :action-docu "make sensitive")
             (:view-of :off
	      :text "off"
	      :action-docu "make insensitive")))))

(defmethod selected-property-sheet-entry (ignore)
  nil)

(defmethod selected-property-sheet-entry ((self interaction-window))
  `(:label "selected?"
    :read-function selected?
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "make selected")
             (:view-of :no
	      :text "no"
	      :action-docu "make deselected")))))

(defmethod view-of-property-sheet-entry (ignore)
  nil)

(defmethod view-of-property-sheet-entry ((self view))
  `(:class text-property-field
    :label "view-of"
    :read-function get-view-of
    :write-function set-view-of
    :read-transformation write-to-string
    :write-transformation (lambda (value) (eval (convert-from-string value)))
    :value-part 
    (:font (:size :small)
     :reactivity-entries ((:copy-property
			   (call :self copy-property 'identity
				 :writer 'view-of
				 :mouse-documentation
				 "Identify window for view-of"))
			  ))))

(defmethod reactivity-event-keys ((self interaction-window))
  (with-slots (reactivity) self
    (mapcar #'car
	    reactivity)))

(defmethod reactivity-property-sheet-entry (ignore)
  nil)

(defmethod reactivity-property-sheet-entry ((self interaction-window))
  `(:class text-property-field
    :label "reactivity"
    :read-function reactivity-event-keys
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel
     :font (:size :small)
     :mouse-feedback :border
     :reactivity-entries ((:menu "Change reactivity"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-reactivity-sheet))
			  (:copy-property
			   (call :self copy-property 'reactivity
				 :window-type 'interaction-window
				 :mouse-documentation
				 "Identify reactivity"))))))

#||
(defmethod reactivity-property-sheet-entry ((self interaction-window))
  `(:class text-property-field
    :label "reactivity"
    :read-function reactivity))
||#

(defmethod mouse-feedback-property-sheet-entry (ignore)
  nil)

(defmethod mouse-feedback-property-sheet-entry ((self interaction-window))
  `(:label "mouse-feedback"
    :read-function mouse-feedback
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :none  
              :action-docu "Select no mouse-feedback"
              :text "none")
             (:view-of :border 
              :action-docu "Select border mouse-feedback"
              :text "border")
             (:view-of :inverse 
              :action-docu "Select inverse mouse-feedback"
              :text "inverse")))))

(defmethod mouse-documentation-property-sheet-entry (ignore)
  nil)

(defmethod mouse-documentation-property-sheet-entry ((self interaction-window))
  `(:class text-property-field
    :label "mouse-documentation"
    :read-function mouse-documentation
    :write-transformation string))

(defmethod compute-mouse-documentation-property-sheet-entry (ignore)
  nil)

(defmethod compute-mouse-documentation-property-sheet-entry ((self interaction-window))
  `(:label "compute-mouse-documentation?"
    :read-function compute-mouse-documentation?
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :never  
              :action-docu "Do not compute mouse-documentation"
              :text "never")
             (:view-of :if-needed 
              :action-docu "Compute mouse-documentation if needed"
              :text "if-needed")
             (:view-of :always
              :action-docu "Always compute mouse-documentation"
              :text "always")))))

(defmethod part-class-property-sheet-entry (ignore)
  nil)

(defmethod (setf part-class) (new-class (self uniform-part-intel))
  (with-slots (part-class) self
    (setf part-class new-class)))

(defmethod part-class-property-sheet-entry ((self uniform-part-intel))
  `(:class text-property-field
    :label "part-class"
    :read-function part-class
    :value-part 
    (:font (:size :small)
     :reactivity-entries ((:copy-property
			   (call :self copy-property 'part-class
				 :window-type 'uniform-part-intel
				 :mouse-documentation
				 "Identify window for part-class"))))))

(defmethod part-mouse-feedback-property-sheet-entry (ignore)
  nil)

(defmethod part-mouse-feedback-property-sheet-entry ((self basic-menu))
  `(:label "part-mouse-feedback"
    :read-function part-mouse-feedback
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :none  
              :action-docu "Select no part-mouse-feedback"
              :text "none")
             (:view-of :border 
              :action-docu "Select border part-mouse-feedback"
              :text "border")
             (:view-of :inverse 
              :action-docu "Select inverse part-mouse-feedback"
              :text "inverse")))))

(defmethod part-font-property-sheet-entry (ignore)
  nil)

(defmethod part-font-property-sheet-entry ((self text-menu))
  `(:class text-property-field
    :label "part-font"
    :read-function part-font
    :read-transformation (lambda (value)
			   (convert-to-readable-string
			    (get-font-description value)))
    :value-part 
    (:reactivity-entries ((:menu "Change part font"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-font-sheet
				          :reader 'part-font))
			  (:copy-property
			   (call :self copy-property 'font
				 :writer 'part-font
				 :window-type 'font-mixin
				 :mouse-documentation "Identify font"))))))

(defmethod popup-position-property-sheet-entry (ignore)
  nil)

(defmethod popup-position-property-sheet-entry ((self popup-window))
  `(:label "popup-position"
    :read-function popup-position
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :none  
              :action-docu "Select popup-position at current position of popup-window"
              :text "none")
             (:view-of :pointer  
              :action-docu "Select popup-position at position of pointer"
              :text "pointer")
             (:view-of :pointer-centered  
              :action-docu "Select popup-position centered relative to pointer position"
              :text "pointer-centered")))))

(defmethod hide-on-mouse-exit?-property-sheet-entry (ignore)
  nil)

(defmethod hide-on-mouse-exit?-property-sheet-entry ((self popup-window))
  `(:label "hide on mouse-exit?"
    :name :hide-on-mouse-exit?
    :read-function hide-on-mouse-exit?
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "Hide when mouse leaves")
             (:view-of :no
	      :text "no"
	      :action-docu "Don not hide when mouse leaves")))))

(defmethod hide-on-part-event?-property-sheet-entry (ignore)
  nil)

(defmethod hide-on-part-event?-property-sheet-entry ((self popup-window))
  `(:label "hide on part-event?"
    :name :hide-on-part-event?
    :read-function hide-on-part-event?
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "Hide when part-event is sent")
             (:view-of :no
	      :text "no"
	      :action-docu "Do not hide when part-event is sent")))))

(defmethod destroy-after?-property-sheet-entry (ignore)
  nil)

(defmethod destroy-after?-property-sheet-entry ((self popup-window))
  `(:label "destroy after?"
    :name :destroy-after?
    :read-function destroy-after?
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "Destroy after window is hidden")
             (:view-of :no
	      :text "no"
	      :action-docu "Don not destroy after window is hidden")))))

(defmethod popup-part-connection-property-sheet-entry (ignore)
  nil)

(defmethod popup-part-connection-property-sheet-entry ((self popup-part-connection))
  `(:label "popup-part-connection"
    :read-function popup-part-connection
    :read-transformation convert-nil-to-none
    :write-transformation convert-none-to-nil
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :none  
              :action-docu "Select popup-part-connection nil"
              :text "nil")
             (:view-of :self  
              :action-docu "Select popup-part-connection :self"
              :text "self")
             (:view-of :part-of  
              :action-docu "Select popup-part-connection :part-of"
              :text "part-of")
             (:view-of :view-of  
              :action-docu "Select popup-part-connection :view-of"
              :text "view-of")))))
      
(defmethod display-position-property-sheet-entry (ignore)
  nil)

(defmethod display-position-property-sheet-entry ((self basic-dispel))
  `(:label "display-position"
    :read-function display-position
    :write-function 
    (lambda (view-of value) 
         (setf (adjust-size? view-of) nil)
         (setf (display-position view-of) value)
         (update-part-of-property-sheet (part-of *self*) :adjust-size?)
         (update view-of))
    :value-part
    (:class single-choice-bitmap-menu
     :layouter (multiline-distance-layouter 
                :orientation :down
                :items-per-line 3
                :line-offset 40
                :distance 0)
     :border-width 1
     :inside-border 0
     :parts ((:view-of :upper-left
              :action-docu "Select upper-left Position"
              :bitmap "display-pos")
             (:view-of :left-center
              :action-docu "Select left-center Position"
	      :bitmap "display-pos")
             (:view-of :lower-left
              :action-docu "Select lower-left Position"
              :bitmap "display-pos")
             (:view-of :upper-center
              :action-docu "Select upper-center Position"
              :bitmap "display-pos")
             (:view-of :center
              :action-docu "Select center Position"
              :bitmap "display-pos")
             (:view-of :lower-center
              :action-docu "Select lower-center Position"
              :bitmap "display-pos")
             (:view-of :upper-right
              :action-docu "Select upper-right Position"
              :bitmap "display-pos")
             (:view-of :right-center
              :action-docu "Select right-center Position"
              :bitmap "display-pos")
             (:view-of :lower-right
              :action-docu "Select lower-right Position"
              :bitmap "display-pos")))))


(defmethod layout-property-sheet-entry (ignore)
  nil)

(defmethod layout-property-sheet-entry ((self layouted-window))
  `(:label "layout"
    :read-function (lambda (view-of)
			(let ((layouter (layouter view-of)))
			  (when layouter 
			    (class-name (class-of layouter)))))
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel
     :mouse-feedback :border
     :reactivity-entries
     ((:menu "Change layout"
	 (call :self hide-popup-parent)
	 (call :view-of select-layout-meta-sheet-for))))))

(defmethod margin-thickness-property-sheet-entry (ignore)
  nil)

(defmethod margin-thickness-property-sheet-entry ((self margin))
  `(:class text-property-field
    :label "thickness"
    :read-function margin-thickness
    :read-transformation write-to-string
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'margin-thickness
				 :window-type 'margin
				 :mouse-documentation
				 "Identify margin thickness"))))))

(defmethod margin-location-property-sheet-entry (ignore)
  nil)

(defmethod margin-location-property-sheet-entry ((self margin))
  `(:label "location"
    :read-function margin-location
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :left 
              :action-docu "Put margin to the left"
              :text "left")
             (:view-of :right 
              :action-docu "Put margin to the right"
              :text "right")
             (:view-of :top 
              :action-docu "Put margin to the top"
              :text "top")
             (:view-of :bottom  
              :action-docu "Put margin to the bottom"
              :text "bottom")))))

(defmethod title-property-sheet-entry (ignore)
  nil)

#||
(defmethod title-property-sheet-entry ((self margined-window))
  (when (margin-label self)
    '(:class text-property-field
      :label "title"
      :read-function title
      :write-transformation string)))

(defmethod margin-label ((self margined-window))
  (find-child self 'margin-label))

(defmethod title ((self margined-window))
  (let ((margin-label (margin-label self)))
    (if margin-label (text margin-label))))

(defmethod (setf title) (new-text (self margined-window))
  (let ((margin-label (margin-label self)))
    (if margin-label (setf (text margin-label) new-text))))
||#

(defmethod title-property-sheet-entry ((self title-window))
  `(:class text-property-field
    :label "title"
    :read-function title
    :write-transformation string))

(defmethod action-property-sheet-entry (ignore)
  nil)

(defmethod action-property-sheet-entry ((self action-mixin))
  `(:class text-property-field
    :label "action"
    :read-function actions
    :read-transformation convert-to-readable-string-from-list
    :write-transformation convert-from-string-to-list
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'actions
				 :window-type 'icon
				 :mouse-documentation "Identify action"))))))

(defmethod action-property-sheet-entry ((self basic-menu))
  `(:class text-property-field
    :label "action"
    :read-function menu-actions
    :read-transformation convert-to-readable-string-from-list
    :write-transformation convert-from-string-to-list
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'menu-actions
				 :window-type 'basic-menu
				 :mouse-documentation "Identify action"))))))

(defmethod menu-actions ((self basic-menu))
  (let ((part-event-actions (reactivity-actions-for self :part-event)))
    (unless (eq part-event-actions t)
      part-event-actions)))

(defmethod (setf menu-actions) (new-actions (self basic-menu))
  (apply #'change-reactivity self :part-event new-actions))

(defmethod action-docu-property-sheet-entry (ignore)
  nil)

(defmethod action-docu-property-sheet-entry ((self soft-button))
  `(:class text-property-field
    :label "action documentation"
    :read-function action-docu
    :read-transformation identity
    :write-transformation identity
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'action-docu
				 :window-type 'soft-button
				 :mouse-documentation
				 "Identify action docu"))))))

(defmethod action-docu ((self soft-button))
  (reactivity-documentation-for self :select))

(defmethod (setf action-docu) (new-docu (self soft-button))
  (setf (reactivity-documentation-for self :select)
      (convert-to-readable-string new-docu)))

(defmethod action-mode-property-sheet-entry (ignore)
  nil)

(defmethod action-mode-property-sheet-entry ((self switch))
  `(:label "action-mode"
    :name :action-mode
    :read-function action-mode
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :up
	      :text "up"
	      :action-docu "Act when part appears")
             (:view-of :down
	      :text "down"
	      :action-docu "Act when part disappears")))))
                       
(defmethod text-property-sheet-entry (ignore)
  nil)

(defmethod text-property-sheet-entry ((self text-dispel))
  `(:class text-property-field
    :label "text"
    :read-function text
    :write-transformation string
    :value-part
    (:reactivity-entries ((:copy-property
			   (call :self copy-property 'text
				 :window-type 'text-dispel
				 :mouse-documentation "Identify text"))))))
                       
(defmethod font-property-sheet-entry (ignore)
  nil)

(defmethod font-property-sheet-entry ((self font-mixin))
  `(:class text-property-field
    :label "font"
    :read-function font
    :read-transformation (lambda (value)
			   (convert-to-readable-string
			    (get-font-description value)))
    :value-part 
    (:reactivity-entries ((:menu "Change font"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-font-sheet))
			  (:copy-property
			   (call :self copy-property 'font
				 :window-type 'font-mixin
				 :mouse-documentation "Identify font"))))))

(defmethod font-property-sheet-entry ((self title-window))
  `(:class text-property-field
    :label "title-font"
    :read-function title-font
    :read-transformation (lambda (value)
			   (convert-to-readable-string
			    (get-font-description value)))
    :value-part 
    (:reactivity-entries ((:menu "Change title font"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-font-sheet
				          :reader 'title-font))
			  (:copy-property
			   (call :self copy-property 'font
				 :writer 'title-font
				 :window-type 'font-mixin
				 :mouse-documentation "Identify font"))))))

(defmethod editable?-property-sheet-entry (ignore)
  nil)

(defmethod editable?-property-sheet-entry ((self text-dispel))
  `(:label "editable?"
    :read-function editable?
    :write-function set-editable? 
    :write-transformation convert-to-boolean
    :read-transformation convert-from-boolean
    :value-part
    (:class single-choice-text-menu
     :layouter (distance-layouter :orientation :right)
     :parts ((:view-of :yes
	      :text "yes"
	      :action-docu "make text editable")
             (:view-of :no
	      :text "no"
	      :action-docu "make text not editable")))))
  
(defmethod editable? ((self text-dispel))
   (reactivity-actions-for self :keyboard))
   
(defmethod set-editable? ((self text-dispel) new-value)
   (if new-value 
      (make-editable self)
     (make-ineditable self)))

(defmethod bitmap-property-sheet-entry (ignore)
  nil)

(defmethod bitmap-property-sheet-entry ((self bitmap-dispel))
  `(:class text-property-field
    :label "bitmap"
    :read-function get-bitmap-name
    :write-function (lambda (dispel bitmap-name)
		      (setf (bitmap dispel) bitmap-name))
    :write-transformation string
    :value-part
    (:reactivity-entries ((:double-left-button "Edit bitmap"
			   (call :self hide-popup-parent)
			   (call :view-of edit-bitmap))
			  (:menu "Bitmap menu"
			   (call :self hide-popup-parent)
			   (call :view-of select-meta-bitmap-menu))
			  (:copy-property
			   (call :self copy-property 'bitmap
				 :window-type 'bitmap-dispel
				 :mouse-documentation "Identify bitmap"))))))

(defmethod read-function-property-sheet-entry (ignore)
  nil)

(defmethod read-function-property-sheet-entry ((self application-mixin))
  `(:class text-property-field
    :label "read-function"
    :read-function read-function
    :value-part 
    (:font (:size :small)
     :reactivity-entries ((:copy-property
			   (call :self copy-property 'read-function
				 :window-type 'application-mixin
				 :mouse-documentation
				 "Identify window for read-function"))))))

(defmethod write-function-property-sheet-entry (ignore)
  nil)

(defmethod write-function-property-sheet-entry ((self application-mixin))
  `(:class text-property-field
    :label "write-function"
    :read-function write-function
    :value-part 
    (:font (:size :small)
     :reactivity-entries ((:copy-property
			   (call :self copy-property 'write-function
				 :window-type 'application-mixin
				 :mouse-documentation
				 "Identify window for write-function"))))))

(defmethod read-transformation-property-sheet-entry (ignore)
  nil)

(defmethod read-transformation-property-sheet-entry ((self property-field))
  `(:class text-property-field
    :label "read-transformation"
    :read-function read-transformation
    :value-part 
    (:font (:size :small)
	   :reactivity-entries
	   ((:copy-property
	     (call :self copy-property 'read-transformation
		   :window-type 'property-field
		   :mouse-documentation
		   "Identify window for read-transformation"))))))

(defmethod write-transformation-property-sheet-entry (ignore)
  nil)

(defmethod write-transformation-property-sheet-entry ((self property-field))
  `(:class text-property-field
    :label "write-transformation"
    :read-function write-transformation
    :value-part 
    (:font (:size :small)
     :reactivity-entries
     ((:copy-property
       (call :self copy-property 'write-transformation
	     :window-type 'property-field
	     :mouse-documentation
	     "Identify window for write-transformation"))))))
