;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Forms
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/forms.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 07/24/92 11:31:19
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 7/27/90   (Hubertus)  - fixed horrible bug in SET-VALUE which damaged the
;;;                         write-function of a form-field.
;;; 
;;;_____________________________________________________________________________


;;;*****************************************************************************
;;;  NOTE: Forms are obsolete. Do NOT use them any longer. Use property sheets
;;;        instead
;;;*****************************************************************************

(in-package :xit)

;_______________________________________________________________________________
;
;                                 Form Field
;_______________________________________________________________________________

(defcontact form-field (intel)
  ((name :initform :form-field)
   (layouter :initform 'offset-layouter)
   (label :initform nil :accessor label :initarg :label)
   (editable? :type boolean :initform t :accessor editable? :initarg :editable?)
   (manage-list? :type boolean :initform t :accessor manage-list? :initarg :manage-list?)
   (label-width :type card16 :accessor label-width :initarg :label-width)
   (value-width :type card16 :accessor value-width :initarg :value-width)
   (part-distance :type card16 :accessor part-distance :initarg :part-distance)
   (label-font :type font :accessor label-font :initarg :label-font)
   (value-font :type font :accessor value-font :initarg :value-font)
   (read-function :accessor read-function :initarg :read-function)
   (write-function :initform nil :accessor write-function :initarg :write-function)
   (read-transformation :initform #'convert-to-readable-string
			:accessor read-transformation :initarg :read-transformation)
   (write-transformation :initform #'convert-from-string
     :accessor write-transformation :initarg :write-transformation)
   (reactivity :initform '((:part-event (call :self write-value)))))
  (:resources
    label-width
    value-width
    part-distance
    (label-font :initform :default)
    (value-font :initform :default)
    )
  (:documentation "intel representing an attribute-value pair used as part of a form intel"))

(defmethod initialize-instance :after ((self form-field) &rest init-list
				       &key label-part value-part)
   (declare (ignore init-list))
   (with-slots
     (layouter label label-width value-width part-distance
      label-font value-font read-function read-transformation editable? manage-list?) self
     (let* ((label-class (or (getf label-part :class)
			     'text-dispel))
	    (label-display-position (or (getf label-part :display-position)
					:upper-left))
	    (label-text (cond (label (convert-to-string label))
			      (read-function (convert-to-string read-function))
			      (t "Input:")))
	    (label-part (apply #'add-part self
			      :class label-class
			      :name :label
			      :display-position label-display-position
			      :text label-text
			      :font label-font
			      (if label-width
				  `(:adjust-size? nil
				    :width ,label-width
				    ,@label-part)
				  label-part)))
	    (value-class (or (getf value-part :class)
			     'text-dispel))
	    (value-mouse-feedback (or (getf value-part :mouse-feedback)
					:border))
	    (value-display-position (or (getf value-part :display-position)
					:upper-left))
	    (value-reactivity (and editable?
				   (not (getf value-part :reactivity-entries))
				   '((:edit))))
	    (value (get-value self))
	    (value-init-list `(:name :value
			       :display-position ,value-display-position
			       :font ,value-font
			       ,@value-part)))
       (when value-width
	 (setq value-init-list `(:adjust-size? nil
				 :width ,value-width
				 ,.value-init-list)))
       (when value-reactivity
	 (setq value-init-list `(:mouse-feedback ,value-mouse-feedback
				 :reactivity ,value-reactivity
				 ,.value-init-list)))
       (setf (offset layouter) (point (+ (if label-width
					     label-width
					     (contact-width label-part))
					 part-distance)
				      0))
       (if (and manage-list? (consp value))
	   (let ((value-part (add-part self
				       :class 'uniform-part-intel
				       :parent self
				       :name :values
				       :part-class value-class
				       :layouter 'distance-layouter)))
	     (dolist (val value)
	       (apply #'add-part value-part
		      :text (funcall read-transformation val)
		      value-init-list)))
	   (apply #'add-part self
		  :class value-class
		  :text (funcall read-transformation value)
		  value-init-list)))))

(defmethod get-value ((self form-field))
  (with-accessors ((read-function read-function) (view-of view-of)) self
    (if view-of
	(if (listp read-function)
	    (eval (subst `',view-of 'view-of read-function))
	    (funcall read-function view-of))
	(eval read-function))))

(defmethod set-value ((self form-field) value)
  (with-accessors ((write-function write-function) (read-function read-function)
		   (view-of view-of)) self
    (if view-of
	(if write-function
	    (if (listp write-function)
		(eval (sublis `((view-of . ',view-of)
				(value  . ',value))
			      write-function))
		(funcall write-function view-of value))
	    (eval `(setf (,read-function ',view-of) ',value)))
	(funcall write-function value))))

(defmethod read-value ((self form-field))
  (with-slots (editable? manage-list? value-width value-font
			 read-transformation) self
    (let* ((values-part (part self :values))
	   (old-value-part (if values-part
			       (part values-part :value)
			     (part self :value)))
	   (value-class (if old-value-part
			    (class-name (class-of old-value-part))
			  'text-dispel))
	   (value-mouse-feedback (if old-value-part
				     (mouse-feedback old-value-part)
				   :border))
	   (value-display-position (if old-value-part
				       (display-position old-value-part)
				     :upper-left))
	   (value-reactivity (when editable?
			       (if old-value-part
				   (reactivity old-value-part)
				 '((:edit)))))
	   (new-value (get-value self))
	   (value-init-list `(:name :value
			      :display-position ,value-display-position
			      :font ,value-font)))
			       
      (when value-width
	(setq value-init-list `(:adjust-size? nil
				:width ,value-width
				,.value-init-list)))
      (when value-reactivity
	 (setq value-init-list `(:mouse-feedback ,value-mouse-feedback
				 :reactivity ,value-reactivity
				 ,.value-init-list)))
      (with-final-layout self
	(delete-part self :values) ; if one exists
	(if (and manage-list? (consp new-value))
	    (let ((value-part (add-part self
					:class 'uniform-part-intel
					:name :values
					:part-class value-class
					:layouter 'distance-layouter)))
	      (delete-part self :value)    ; if one exists
	      (dolist (val new-value)
		(apply #'add-part value-part
		       :text (funcall read-transformation val)
		       value-init-list)))
	    (if (part self :value)
		(setf (text (part self :value))
		  (funcall read-transformation new-value))
		(apply #'add-part self
		       :class value-class
		       :text (funcall read-transformation new-value)
		       value-init-list)))))))

(defmethod write-value ((self form-field))
  (with-slots (write-transformation) self
    (let ((list-value-part (part self :values)))
      (set-value self
		 (if list-value-part
		     (mapcar #'(lambda (val)
				(funcall write-transformation (text val)))
			     (parts list-value-part))
		     (funcall write-transformation (send-part self :value #'text)))))))

;_______________________________________________________________________________
;
;                              Form   
;_______________________________________________________________________________

(defcontact form (uniform-part-intel)
     ((name :initform :form)
      (part-class :initform 'form-field)
      (part-options :allocation :class
		    :initform '((part-editable? . :editable?)
				(part-manage-list? . :manage-list?)
				(part-label-width . :label-width)
				(part-value-width . :value-width)
				(subpart-distance . :part-distance)
				(part-label-font . :label-font)
				(part-value-font . :value-font)))
      (layouter :initform 'distance-layouter)
      (part-editable? :type boolean :initform t
		      :accessor part-editable? :initarg :part-editable?)
      (part-manage-list? :type boolean :initform t
			 :accessor part-manage-list? :initarg :part-manage-list?)
      (part-label-width :type card16 :accessor part-label-width :initarg :part-label-width)
      (part-value-width :type card16 :accessor part-value-width :initarg :part-value-width)
      (subpart-distance :type card16 :accessor subpart-distance :initarg :subpart-distance)
      (part-label-font :type font :accessor part-label-font :initarg :part-label-font)
      (part-value-font :type font :accessor part-value-font :initarg :part-value-font))
     (:resources
       (part-label-width :initform 100)
       (part-value-width :initform 100)
       (subpart-distance :initform 10)
       (part-label-font :initform '(:face :bold))
       (part-value-font :initform '(:face :normal)))
     (:documentation "intel visualizing attribute-value pairs and changing values"))

(defmethod read-values ((self form))
  (broadcast self #'read-value))


;;; 03/22/1991 (Hubertus) ToDo: We should also define SETFs for the part-options
;;; defined by FORM, that broadcast to the parts.

