;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Property Sheet Examples
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/examples/property-sheet-examples.lisp
;;; File Creation Date: 01/31/91 15:16:49
;;; Last Modification Time: 07/24/92 13:07:39
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(proclaim '(special demo-window icon-menu property-sheet-window
	    property-sheet-1 *display*))

		   
(setq property-sheet-window
      (make-window 'intel-example-window
		   :name :property-sheet-examples
		   :x 200 :y 100 :width 500 :height 500
		   :window-icon `(intel-example-icon :parent ,icon-menu
						     :text "Property Sheets")
		   :title "Property Sheets"))

(setq property-sheet-1
    (make-window 'property-sheet
		 :parent property-sheet-window
		 :x 20 :y 40
		 :border-width 1
		 :view-of demo-window
		 :reactivity-entries
		 '((:shift-left-button "Read values" (call :read))

		   (:shift-right-button "Write values" (call :write)))
		 :parts `((:class text-property-field
			   :label "self"
			   :reactivity-entries
			   ((:write-event
			     (call :eval
			       (let ((new-view-of
				      (symbol-value
				       (value *self*))))
				 (unless (eq new-view-of (view-of *self*))
				   (setf (view-of (part-of *self*))
					     new-view-of)
				   (read-from-application
				    (part-of *self*)))))))
			   :value-width 100
			   :value-part (:text "demo-window"))

			  (:class text-property-field
			   :label "class"
			   :read-function (lambda (view-of)
					    (class-name (class-of view-of)))
			   :editable? nil
			   :reactivity-entries ((:write-event)))

			  (:class text-property-field
			   :label "title"
			   :read-function title
			   :write-transformation string)

			  (:class text-property-line-sheet
			   :inside-border 0
			   :parts ((:label "x"
				    :read-function contact-x
				    :write-function
				    (lambda (view-of value)
				      (change-geometry view-of :x value)))
				   (:label "y"
				    :read-function contact-y
				    :write-function
				    (lambda (view-of value)
				      (change-geometry view-of :y value)))
				   (:label "width"
				    :read-function contact-width
				    :write-function
				    (lambda (view-of value)
				      (change-geometry view-of :width value)))
				   (:label "height"
				    :read-function contact-height
				    :write-function
				    (lambda (view-of value)
				      (change-geometry view-of :height value)))))
			    
			  (:label "border width"
			   :read-function contact-border-width
			   :write-function change-window-border-width
			   :value-part
			   (:class text-switch
			    :border-width 1
			    :inside-border 5
			    :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"))))

			  (:label "visibility"
			   :read-function
			   (lambda (view-of)
			     (if (expanded? view-of) :full-size :iconic))
			   :write-function
			   (lambda (view-of value)
			     (case value
			       (:full-size (expand view-of))
			       (:iconic    (shrink view-of))))
			   :reactivity-entries
			   ((:write-event
			     (call :self write-value)
			     (call :part-of read-from-application)))
			   :value-part
			   (:class single-choice-text-menu
			    :layouter (distance-layouter :orientation :right)
			    :parts ((:view-of :full-size :text "full-size")
				    (:view-of :iconic :text "iconic"))))

			  (:label "window icon"
			   :reactivity-entries
			   ((:read-event
			     (call :eval (read-from-application
					  (part *self* :value))))
			    (:write-event
			     (call :eval (write-to-application
					  (part *self* :value)))))
			   :value-part
			   (:class property-sheet
			    :border-width 1
			    :parts
			    ((:class text-property-field
			      :label "text"
			      :read-function
			      (lambda (view-of)
				(let* ((window-icon (window-icon view-of))
				       (text-part
					(or (part window-icon :text)
					    window-icon)))
				  (text text-part)))
			      :write-transformation string
			      :write-function
			      (lambda (view-of value)
				(let* ((window-icon (window-icon view-of))
				       (text-part
					(or (part window-icon :text)
					    window-icon)))
				  (setf (text text-part) value))))
			     (:label "position"
			      :read-function window-icon-pos 
			      :value-part
			      (:class single-choice-text-menu
			       :parts ((:view-of :window :text ":window")
				       (:view-of :window-constrained
					:text ":window-constrained")
				       (:view-of :icon-constrained
					:text ":icon-constrained")
				       (:view-of :constrained 
					:text ":constrained")))))))

			  (:name :state
			   :label "state"
			   :read-function contact-state
			   :value-part
			   (:class single-choice-text-menu
			    :layouter (distance-layouter :orientation :right)
			    :parts ((:view-of :mapped :text ":mapped")
				    (:view-of :managed :text ":managed")
				    (:view-of :withdrawn :text ":withdrawn"))))
			  )))
			    
			   
	
(update-state *display*)
(process-all-events *display*)

(shrink property-sheet-window)

(update-state *display*)
(process-all-events *display*)
	   
