;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Property Sheets
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/property-sheets.lisp
;;; File Creation Date: 01/31/91 14:31:00
;;; Last Modification Time: 07/30/92 14:03:35
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 06/25/1991 (Juergen) new method identification for property-sheets, which
;;;                      returns the list of identifications of its entries;
;;;                      (setf identification) sets the identifications of the
;;;                      entries.
;;;
;;; 10/02/1991 (Hubertus) Clarification: read-function and write-function for
;;;                       property fields accept three types of object:
;;;                       - a symbol that names a real function (no macro or 
;;;                         special-form)
;;;                       - a lambda-expression, i.e., a list whose car is the
;;;                         symbol LAMBDA
;;;                       - a function object as returned by the FUNCTION
;;;                         special form, e.g., #'car or #'(lambda (x) x))
;;;
;;;                       Notice that if you specify a read-function only,
;;;                       this must be a symbol for which a setf function is 
;;;                       defined, because the write-function is assumed to be
;;;                       of the form (setf <symbol>).
;;;                       
;;;                       Incompatible change: general lisp-forms are no longer
;;;                       valid as read- or write-functions.
;;;
;;; 10/08/1991 (Juergen)  Property-sheets now may have parts of types different
;;;                       from property-field.  This may be useful, for
;;;                       example, to have property-sheets as parts of another
;;;                       property-sheet.
;;;
;;; 10/08/1991 (Juergen)  New slot adjust-part-label-width? added to class
;;;                       property-sheet, which decides whether the labels
;;;                       of the property-fields are adjusted to the maximum
;;;                       label size.  Default is t - this is what happened
;;;                       so far.
;;;
;;; 10/08/1991 (Juergen)  New classes property-line-sheet and 
;;;                       text-property-line-sheet, which are property-sheets
;;;                       with parts arranged in one (horizontal) line.
;;;                       They may, for example, be used as parts of regular
;;;                       property-sheets.
;;; 
;;; 06/19/1992 (Juergen)  Optimized read-event for property-sheet by using 
;;;                       with-final-layout                
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________
;
;                                 Property Field
;_______________________________________________________________________________

(defcontact property-field (intel)
  ((name :initform :property-field)
   (layouter :initform `(distance-layouter :orientation :right))
   (label-class :initform 'text-dispel :allocation :class)
   (value-class :initform 'text-dispel :allocation :class)
   (transformer :initform '(basic-transformer))
;   (read-function :initform nil
;		  :accessor read-function :initarg :read-function)
;   (write-function :initform nil
;		   :accessor write-function :initarg :write-function)
;   (read-transformation :initform #'identity
;     :accessor read-transformation :initarg :read-transformation)
;   (write-transformation :initform #'identity
;     :accessor write-transformation :initarg :write-transformation)
   (reactivity :initform '((:part-event (call :write))
			   (:read-event (call :self read-value))
			   (:write-event (call :self write-value)))))
  (:documentation "Intel representing an attribute-value pair consisting
                   pf a label part (a text dispel) and a value part (any
                   interaction object).
                   It is used as part of a property sheet"))

(defmethod initialize-instance :after ((self property-field) &rest init-list
				       &key label label-font
				            label-value-distance
				            label-part value-part
					    read-transformation write-transformation
					    (read-initially? t))
   (declare (ignore init-list))
   (with-slots (layouter label-class value-class) self
     (when label-value-distance
       (with-slots (distance) layouter
	 (setf distance label-value-distance)))
     (when read-transformation
       (setf (read-transformation self) read-transformation))
     (when write-transformation
       (setf (write-transformation self) write-transformation))
     (let ((label-init-list `(:name :label ,@label-part
			      :font ,label-font :adjust-size? nil
			      :display-position :upper-left))
	   (value-init-list `(:name :value ,@value-part))
	   (value-part nil))
       (when label
	 (setq label-init-list
	     `(:text ,label ,.label-init-list)))
       (unless (getf label-init-list :class)
	 (setq label-init-list
	     `(:class ,label-class ,.label-init-list)))
       (unless (getf value-init-list :class)
	 (setq value-init-list
	     `(:class ,value-class ,.value-init-list)))
       (apply #'add-part self label-init-list)
       (setq value-part (apply #'add-part self value-init-list))
       ; the following is necessary for intels specifying a :part-event
       ; (e.g. single-choice-menus), since this event must be passed through
       (when (reactivity-entry value-part :part-event)
	 (change-reactivity value-part :part-event '(call :pass-part-event)))))
   (when read-initially? (read-from-application self)))
  
(defmethod identification ((self property-field))
  (value (part self :value)))

(defmethod (setf identification) (value (self property-field))
  (setf (value (part self :value)) value))

;;; The next 4 function are for backward compatibility
;;; These functions should only be used in connection with a transformer 
;;; that is instance of basic-transformer or a subclass

(defmethod read-transformation ((self property-field))
  (with-slots (transformer) self
    (if transformer (read-transformation transformer)
      #'identity)))

(defmethod (setf read-transformation) (value (self property-field))
  (with-slots (transformer) self
    (if transformer
	(cond ((typep transformer 'basic-transformer)
	       (setf transformer (copy transformer))
	       (with-slots (read-transformation) transformer
		 (setf read-transformation value)))
	  (t (warn "Cannot set read-transformation for ~a. Use basic-transformer."
		transformer)))
      (setf (transformer self) `(basic-transformer :read-transformation ,value)))))
	    
(defmethod write-transformation ((self property-field))
  (with-slots (transformer) self
    (if transformer (write-transformation transformer)
      #'identity)))

(defmethod (setf write-transformation) (value (self property-field))
  (with-slots (transformer) self
    (if transformer
	(cond ((typep transformer 'basic-transformer)
	       (setf transformer (copy transformer))
	       (with-slots (write-transformation) transformer
		 (setf write-transformation value)))
	  (t (warn "Cannot set write-transformation for ~a. Use basic-transformer."
		transformer)))
      (setf (transformer self) `(basic-transformer :write-transformation ,value)))))

;;;(defmethod active-value ((self property-field))
;;  (with-accessors ((read-function read-function) (view-of view-of)) self
;;     (when read-function
;;       (if view-of
;;	   (funcall read-function view-of) 
;;	 (funcall read-function)))))
;;
;;(defmethod (setf active-value) (new-value (self property-field))
;;  (with-accessors ((write-function write-function)
;;		   (read-function read-function)
;;		   (view-of view-of)) self
;;    (if write-function
;;	(if view-of
;;	    (funcall write-function view-of new-value)
;;	  (funcall write-function new-value))
;;      (when view-of
;;	(eval `(setf (,read-function ',view-of) ',new-value))))))
;; 
;;(defmethod identification ((self property-field))
;;  (with-slots (write-transformation) self
;;    (funcall write-transformation
;;	     (value (part self :value)))))
;;
;;(defmethod (setf identification) (new-value (self property-field))
;;  (with-slots (read-transformation) self
;;    (setf (identification (part self :value))
;;	(funcall read-transformation new-value)))
;;  new-value)
;;
;;(defmethod read-value ((self property-field))
;;  (with-slots (read-function) self
;;    (when read-function
;;      (setf (identification self) (active-value self)))))
;;
;;(defmethod write-value ((self property-field))
;;  (with-slots (read-function write-function) self
;;    (when (or write-function read-function)
;;      (setf (active-value self) (identification self)))))

;_______________________________________________________________________________
;
;                           Text Property Field
;_______________________________________________________________________________

(defcontact text-property-field (property-field)
  ((name :initform :text-property-field)
   (value-class :initform 'active-text-dispel :allocation :class)
   (transformer :initform 'string-transformer)
;;   (read-transformation :initform #'convert-to-readable-string)
;;   (write-transformation :initform #'convert-from-string)
   )
  (:documentation "Property field with an active-text-dispel
                   as value part"))

(defmethod initialize-instance :around ((self text-property-field)
				        &rest init-list
				        &key value-font value-width
					     (editable? t)
				             value-part)
   (let ((value-init-list value-part))
     (when value-font
       (setq value-init-list `(:font ,value-font ,@value-init-list)))
     (when value-width
       (setq value-init-list `(:adjust-size? nil
			       :width ,value-width 
			       ,@value-init-list
			       :display-position :upper-left)))
     (unless editable?
       (setq value-init-list `(,@value-init-list
			       :reactivity-entries
			       ((:edit :none))
			       :mouse-feedback :none
			       :min-width nil)))
     (apply #'call-next-method self :value-part value-init-list init-list)))

;_______________________________________________________________________________
;
;                              Property Sheet 
;_______________________________________________________________________________

(defcontact property-sheet (uniform-part-intel)
     ((name :initform :property-sheet)
      (layouter :initform 'distance-layouter)
      (part-class :initform 'property-field)
      (part-options :allocation :class
		    :initform
		    '((part-label-font . :label-font)
		      (part-label-value-distance . :label-value-distance)))
      (part-label-font :type font
		       :reader part-label-font :initarg :part-label-font)
      (part-label-value-distance :accessor part-label-value-distance
				 :initarg :part-label-value-distance)
      (adjust-part-label-width? :type boolean :initform t
				:accessor adjust-part-label-width?
				:initarg :adjust-part-label-width?)
      (reactivity :initform
		  '((:read-event
		     ;(call :self broadcast 'read-from-application)
		     (call :eval (with-final-layout *self*
				   (broadcast *self* 'read-from-application))))
		    (:write-event
		     (call :self broadcast 'write-to-application)))))
     (:resources
       (part-label-font :initform '(:face :bold))
       (part-label-value-distance :initform 20))
     (:documentation "Intel visualizing attribute-value pairs"))

(defmethod identification ((self property-sheet))
  (broadcast self #'value))

(defmethod (setf identification) (value (self property-sheet))
  ; value should be list that contains as much elements as the property-sheet
  ; has entries (parts)
  (mapcar #'(lambda (part val)
	      (setf (value part) val))
	  (parts self)
	  value)
  value)

(defmethod (setf adjust-part-label-width?) :after (value (self property-sheet))
  (recompute-part-label-width self))

(defmethod adjust-part-label-width ((self property-sheet))
  (with-slots (adjust-part-label-width?) self
    (when adjust-part-label-width?
      (let* ((parts (layouted-parts self))
	     (max-width (reduce #'max
				;; 12/12/1991 (Hubertus)
				;; added 0 threshold in case sheet contains
				;; no parts
				(mapcar #'(lambda (p-field)
					    (let ((label-part
						   (part p-field :label)))
					      (if label-part
						  (contact-width label-part)
						0)))
					parts)
				:initial-value 0)))
	(with-final-layout self
	  (dolist (p-field parts)
	    (let ((label-part (part p-field :label)))
	      (when label-part
		(change-geometry label-part :width max-width)
		(change-layout p-field)))))))))

(defmethod recompute-part-label-width ((self property-sheet))
  (with-slots (adjust-part-label-width?) self
    (when adjust-part-label-width?
      (with-final-layout self
	(dolist (p-field (layouted-parts self))
	  (let ((label-part (part p-field :label)))
	    (when label-part
	      (do-adjust-window-size label-part))))
	(adjust-part-label-width self)))))

(defmethod add-part :after ((self property-sheet) &rest part-init-list &key)
  (declare (ignore part-init-list))
  (adjust-part-label-width self))

(defmethod delete-part :after ((self property-sheet) part)
  (declare (ignore part))
  (recompute-part-label-width self))
 
(defmethod (setf part-label-font) (value (self property-sheet))
  (with-slots (part-label-font) self
    (setf part-label-font (convert self value 'font))
    (with-final-layout self
      (dolist (p-field (parts self))
	(let ((label-part (part p-field :label)))
	  (when label-part
	    (setf (font label-part) value))))
      (recompute-part-label-width self))
    value))

(defmethod (setf part-label-value-distance) :after
	   (value (self property-sheet))
  (with-final-layout self
     (dolist (p-field (parts self))
       (setf (distance (layouter p-field)) value))))


(defcontact property-line-sheet (property-sheet)
  ((layouter :initform '(distance-layouter :orientation :right :distance 20))
   (adjust-part-label-width? :initform nil))
  (:resources
   (part-label-value-distance :initform 10))
  (:documentation "Property sheet with parts arranged in horizontal line"))
 
;_______________________________________________________________________________
;
;                            Text Property Sheet 
;_______________________________________________________________________________

(defcontact text-property-sheet (property-sheet)
     ((name :initform :text-property-sheet)
      (part-class :initform 'text-property-field)
      (part-options :allocation :class
		    :initform
		    '((part-label-font . :label-font)
		      (part-label-value-distance . :label-value-distance)
		      (part-value-font . :value-font)
		      (part-value-width . :value-width)))
      (part-value-font :type font
		       :reader part-value-font :initarg :part-value-font)
      (part-value-width :type card16
			:reader part-value-width :initarg :part-value-width))
     (:resources
       (part-value-font :initform :default)
       (part-value-width :initform nil))
     (:documentation "Property sheet with textual value parts"))


(defmethod (setf part-value-font) (value (self text-property-sheet))
  (with-slots (part-value-font) self
    (setf part-value-font (convert self value 'font))
    (with-final-layout self
      (dolist (p-field (parts self))
	(let ((value-part (part p-field :value)))
	  (when value-part
	    (setf (font value-part) value)))))
    value))

(defcontact text-property-line-sheet (property-line-sheet text-property-sheet)
  ()
  (:documentation "Text property sheet with parts arranged in horizontal line"))
