;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT Examples
;;;                       Module: Color Slider Examples
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/resource-sheet.lisp
;;; File Creation Date: 02/18/91 09:52:51
;;; Last Modification Time: 10/09/92 12:50:51
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;04/26/1991 (Matthias) (setf view-of) :before (t hyper-paned-window)
;;;                       now recognized virtuals, that have no border-width
;;;
;;; 05/21/1992 (Juergen) Moved classes color-identifier, color-dispel,
;;;                      editable-value-dispel, window-dispel, 
;;;                      identifier-mixin, and window-identifier-dispel 
;;;                      to color-sheet file,
;;;                      since they are first used there.
;;; 10/08/1992 (Matthias) added focus-mixin to resource-property-sheet
;;;_____________________________________________________________________________

;; Usage
;; (setq *resource-sheet* (make-resource-sheet))

(in-package :xit)

(defcontact hyper-text-switch (text-switch)
  ())

(defmethod identification ((self hyper-text-switch))
  (selection self))

(defclass hyper-color-control (color-control)
  ((resource-sheet :accessor resource-sheet)))

(defcontact broadcast-to-managed-mixin ()
  ((reactivity :initform
	      '((:read-event
		 (call :contact broadcast
		       '(lambda (part)
			 (when (eq (contact-state part) :mapped)
			   (read-from-application part)))))
		(:write-event
		 (call :contact broadcast
		       '(lambda (part)
			 (when (eq (contact-state part) :mapped)
			   (write-from-application part)))))))))

(defcontact broadcast-if-view-set-mixin ()
  ((reactivity :initform
	      '((:read-event
		 (call :contact broadcast
		       '(lambda (part)
			 (when (view-of part)
			   (read-from-application part)))))
		(:write-event
		 (call :contact broadcast
		       '(lambda (part)
			 (when (view-of part)
			   (write-from-application part)))))))))

(defcontact hyper-paned-window (broadcast-if-view-set-mixin
				 popup-part-connection
				  paned-window)
  ((popup-part :initform :default)))

 
(defcontact hyper-property-sheet (broadcast-to-managed-mixin property-sheet)
  ((popup-part :initform :default)
   (inside-border :initform 0)))

(defmethod (setf view-of) :before (value (self hyper-paned-window))
  (setf (configuration (layouter self)) 'configuration-2)
  (let  ((colors-part (part self :window-colors)))
    (broadcast colors-part '(lambda (part)
			     (setf (contact-state part) :managed)))
    
    (flet ((active (part-name)
	     (setf (contact-state (part colors-part part-name)) :mapped)))
      (when (background-defined value)
	(active 'background-color)
	(active 'window-border-color))
      (when (foreground-defined value)
	(active 'foreground))))
  (setf (contact-state (part self :border-width)) :managed)
  (when (border-width-defined value)
    (setf (contact-state (part self :border-width)) :mapped)))
      
(defmethod border-width-defined ((self t)) nil)
(defmethod border-width-defined ((self contact)) t)


;;;---------------------------------------------------------------------
;;;                   Background Identifier Field
;;;---------------------------------------------------------------------

(defcontact background-dispel (editable-value-dispel)
  ((name :initform :background-dispel)
   (value-text-transformation :initform
			      '(let ((value (value *contact*)))
				(typecase value
				  (pixel (get-pixel-name *contact* value))
				  (t (convert-to-readable-string value)))))
   (text-value-transformation
    :initform
    '(let ((value (convert-from-string (text *contact*))))
      (convert *contact* value
       '(or (member :none :parent-relative) pixel pixmap))))
   (text-test :initform
	      '(convert *contact*
		(convert-from-string (text *contact*))
		'(or (member :none :parent-relative) pixel pixmap)))))

(defcontact background-identifier (bg-fg-identifier-mixin
			      property-identifier-mixin background-dispel)
  ())

;;;---------------------------------------------------------------------
;;;                   Palette Mixin
;;;---------------------------------------------------------------------

(defcontact palette-mixin ()
  ())

#||(defmethod initialize-instance :around ((self palette-mixin)
					&rest initargs
					&key reactivity-entries)
 (apply #'call-next-method self :reactivity-entries
	(append reactivity-entries
		'((:single-right-button
	     "Palette"
	     (call :eval
	      (let* ((resource-sheet (part-of (part-of (part-of *contact*))))
		     (color-sheet (color-sheet resource-sheet))
		     (control ;(control  resource-sheet) ;10/08/1991 (Juergen) 
		      (view-of color-sheet)))
		(multiple-value-bind (color exact-color)
		    (convert *contact*
				 (convert-from-string (text *contact*))
				 'color)
		  (setf (color-window control) (view-of (part-of *contact*)))
		  (setf (color-reader control)
		      (contact-name (part-of *contact*)))
		  (setf (color control)
		    (cond (color exact-color)
			  ((pixel-to-color (identification  *contact*)))
			  ((pixel-to-color (funcall (color-reader control)
						    (color-window control))))
			  (t (pixel-to-color 1))))
		(totop-window color-sheet)))))))
	initargs))
||#

(defmethod initialize-instance :around ((self palette-mixin)
					&rest initargs
					&key reactivity-entries)
 (apply #'call-next-method self :reactivity-entries
	(append reactivity-entries
		'((:single-right-button
	     "Palette"
	     (call :eval
	      (let* ((resource-sheet (part-of (part-of (part-of *contact*))))
		     (color-sheet (color-sheet resource-sheet))
		     (control ;(control  resource-sheet) ;10/08/1991 (Juergen) 
		      (view-of color-sheet)))
		(multiple-value-bind (color exact-color)
		    (convert *contact*
				 (convert-from-string (text *contact*))
				 'color)
		  (setf (identification *contact*)
		      (convert *contact* (specify-color-value color-sheet
				       :window (view-of (part-of *contact*))
				       :color-reader (contact-name (part-of *contact*))
				       :initial-value
				       (cond 
					(color exact-color)
					((pixel-to-color (identification  *contact*)))
					((pixel-to-color (funcall (color-reader control)
						    (color-window control))))
					(t (pixel-to-color 1))))
			       'pixel))
		  (write-to-application *contact*)))))))
	initargs))

;;;---------------------------------------------------------------------
;;;                  Palette dispels
;;;---------------------------------------------------------------------

(defcontact background-palette-dispel (palette-mixin background-identifier)
  ())

(defmethod write-to-application :after ((self background-palette-dispel))
  (setf (changed? (part-of self)) t))

(defcontact pixel-palette-dispel (palette-mixin pixel-identifier)
  ())

(defmethod write-to-application :after ((self pixel-palette-dispel))
  (setf (changed? (part-of self)) t))
    
;;;---------------------------------------------------------------------
;;;                   Resource fields
;;;---------------------------------------------------------------------

(defcontact write-resource-mixin ()
  ((output-transformation :initform #'value)
   (changed? :initform nil :accessor changed?)))

(defmethod write-to-application :after ((self write-resource-mixin))
  (setf (changed? self) t))

(defmethod read-from-application :after ((self write-resource-mixin))
  (setf (changed? self) nil))

(defcontact size-text-dispel (active-text-dispel)
  ((border-width :initform 1)))

(defcontact bordered-text-dispel (active-text-dispel)
  ((border-width :initform 1)))

(defcontact resource-property-field (write-resource-mixin text-property-field)
  ((name :initform :resource-property-field)
   (label-class :initform 'bold-text-dispel)
   (value-class :initform 'active-text-dispel :allocation :instance
		:initarg :value-class)
   (inside-border :initform 0)
   (layouter :initform '(distance-layouter :orientation :right :distance 10))))

(defcontact size-property-field (resource-property-field)
  ((value-class :initform 'size-text-dispel)))

(defmethod initialize-instance :around ((self size-property-field) &rest initargs
					&key value-part)
  (apply #'call-next-method self
	 :label-value-distance 10
	 :value-part
	 (append value-part '(:display-position :upper-right :width 40))
	 initargs))

(defcontact bold-resource-field (write-resource-mixin bold-property-field)
  ())

(defun bg-output-transform (resource-field)
  (let* ((text (text (part resource-field :value)))
	 (converted (ignore-errors (convert-from-string text))))
    (typecase converted
	     ((member :none :parent-relative nil) converted)
	     ((or pixel pixmap) converted)
	     (t text))))

(defmethod read-value ((self bold-resource-field ))
  (with-slots (read-function) self
    (when (and (view-of self) read-function)
      (setf (value self) (application-value self)))))

(defmethod read-value ((self resource-property-field ))
  (with-slots (read-function) self
    (when (and (view-of self) read-function)
      (setf (value self) (application-value self)))))

;;;---------------------------------------------------------------------
;;;    Color Resource Fields
;;;---------------------------------------------------------------------

(defcontact background-palette-resource-dispel (write-resource-mixin
						background-palette-dispel)
  ())

(defcontact pixel-palette-resource-dispel (write-resource-mixin
						pixel-palette-dispel)
  ())




;;;---------------------------------------------------------------------
;;;                   Aux Foos
;;;---------------------------------------------------------------------

(defmethod foreground (self)
  (format t "Warning: foreground not defined")
  0)

(defmethod hyper-change-window-border-color ((self contact) color-name)
  (setf (window-border self) (convert self color-name 'pixel)))

;;;---------------------------------------------------------------------
;;;                   Resource Property Sheet
;;;---------------------------------------------------------------------

(defclass output-file-mixin ()
  ((output-file :type (or nil pathname) :initarg :output-file
		:accessor output-file :initform nil)))

(defcontact resource-property-sheet (output-file-mixin focus-mixin
				     window-icon-mixin hyper-paned-window )
  ((color-sheet :reader color-sheet)))

#||
(defmethod get-default-icon ((self resource-property-sheet) &rest init-list)
  (apply #'make-window 'soft-button
	 :background "white"
	 :inside-border 2
	 :text-part `(:text ,(text (part self :title)))
	 :bitmap-part :none
	 :reactivity '((:single-middle-button
		        "Move window"
		        (call :contact move-window)))
         init-list))
||#

(defmethod get-default-icon ((self resource-property-sheet) &rest init-list)
  (apply #'make-window 'text-icon
	 :border-width 0
	 :inside-border 0
	 :layouter '(aligning-distance-layouter
		     :alignment :center
		     :distance -1)
	 :text-part `(:border-width 1
		      :background "white"
		      :text ,(text (part self :title))
		      :font (:size :small))
	 :bitmap-part '(:bitmap "xresource" :border-width 1 :background "white")
	 :reactivity '((:move))
         init-list))

(defmethod destroy :before ((self resource-property-sheet))
  (when (slot-boundp self 'color-sheet)
    (with-slots (color-sheet) self
    (destroy color-sheet))))

(defmethod pretty-print-to-output-file ((self output-file-mixin) form)
  (unless (probe-file (output-file self))
    (with-open-file (out (output-file self)
		   :direction :output)
      (format out "~a~%" "(in-package :xit)")))
  (with-open-file (out (output-file self)
		   :direction :output
		   :if-exists :append
		   :if-does-not-exist :create)
    (let ((*print-pretty* t))
      (print form out))))

(defun create-define-resources-form (resource-pattern resource-list)
  (let ((result nil))
    (dolist (rl resource-list)
      (push (second rl) result)
      (push (append resource-pattern (list (first rl))) result))
    (cons 'define-resources result)))

(defmethod write-class-resources-file ((self resource-property-sheet))
  
  (let ((resource-list nil)
	(resource-pattern (list '*
				(identification (part self :window-class)))))
    (macrolet ((push-resource (name reader field)
		 `(let ((field ,field))
		    (when (changed? field)
		      (push (list ,name
				(funcall ,reader field))
			  resource-list)
		      (setf (changed? field) nil)))))
      (push-resource 'name 'identification (part self :name))
    (push-resource 'x 'identification (part (part self :window-x-width) :x))
    (push-resource 'width 'identification (part (part self :window-x-width) :width))
    (push-resource 'y 'identification (part (part self :window-y-height) :y))
    (push-resource 'height 'identification (part (part self :window-y-height) :height))
    (push-resource 'border-width 'identification (part self :border-width))
    (let ((colors (part self :window-colors)))
      (print colors)
      (when (eq (contact-state (part colors 'background-color)) :mapped)
	(push-resource 'background 'bg-output-transform
		       (part colors  'background-color))) 
      (when (eq (contact-state (part colors 'foreground)) :mapped)
	(push-resource 'foreground 'bg-output-transform (part colors  'foreground)))
      (when (and (eq (contact-state (part colors 'window-border-color)) :mapped)
		 (not (string=  "" (bg-output-transform
				    (part colors  'window-border-color)))))
	(push-resource 'border 'bg-output-transform
		       (part colors  'window-border-color))))
    (when resource-list
      (pretty-print-to-output-file self
	   (create-define-resources-form resource-pattern resource-list))))))
    
   
 
  
(defmethod initialize-instance :after ((self  resource-property-sheet)
				       &rest initargs)
  (with-slots (color-sheet) self
    (setf color-sheet
      (make-color-sheet (contact-parent self)
			:window-editable? nil :menu-editable? nil))))

(define-resources
 (* resource-property-window x) 100
 (* resource-property-window y) 250
 (* resource-property-window width) 480
 (* resource-property-window height) 260
 (* resource-property-window border-width) 2
 (* resource-property-window background) "gray97")
 
(defun make-resource-sheet (&optional (toplevel *toplevel*))
    (make-window 'resource-property-sheet
		 :name 'resource-property-window
		 :inside-border 3
		 :view-of nil
		 :adjust-size? nil
		 :reactivity-entries
		 '((:single-left-button "Totop Window" (call :totop))
		   (:double-left-button "Shrink" (call :contact shrink))
		   (:shift-left-button "Read values" (call :read))

		   (:shift-right-button "Write values" (call :write))
		   (:single-middle-button "Move window" (call :move))
		   (:single-right-button "Menu" (call :popup-part)))
		 :parts `((:class bold-text-dispel
				  :name :title
				  :adjust-size? nil
				  :background "black"
				  :foreground "white"
				  :text "Resources Property Sheet")
			  (:class bold-resource-field
				  :name :select-window
			   :label "Select Window:" 
			   :value-class window-identifier-dispel
			   :value-part (:min-width 120)
			   :reactivity-entries
			   ((:write-event
			     (call :eval
			       (let ((new-view-of
				      (identification *contact*)))
				 (unless (eq new-view-of (view-of *contact*))
				   (setf (view-of (part-of *contact*))
					     new-view-of)
				   (read-from-application
				    (part-of *contact*)))))))
			   :value-part (:text ""))

			  (:class resource-property-field
			   :name :window-class
			   :label "class:"
			   :value-part (:min-width 120)
			    :editable? nil
			    :read-function
			    (lambda (view-of)
			      (class-name (class-of view-of))))

			  (:class resource-property-field
				  :name :name
				  :label "name:" :editable? nil
				  :value-part (:min-width 120)
				  :read-function contact-name)

			  (:class bold-text-dispel
				  :name :size-header
				 :text "Size")
			  (:class hyper-property-sheet
				  :part-label-value-distance 10
				  :name :window-x-width
			   :parts
			   ((:class size-property-field
				 :name :x
				 :label "x:" :value-width 40
				 :read-function contact-x 
				 :reactivity-entries
				 ((:write-event (call :eval
						    (change-geometry
						     (view-of *contact*)
						  :x (identification *contact*))))))
			    (:class size-property-field
				 :name :width
				 :label "width:" :value-width 40
				 :read-function contact-width
				 :write-function change-window-width)
			  ))
			  (:class hyper-property-sheet
				  :part-label-value-distance 10
				  :name :window-y-height
			   :parts
			   ((:class size-property-field
				 :name :y
				 :label "y:" :value-width 40
				 :read-function contact-y 
				 :reactivity-entries
				 ((:write-event
				   (call :eval
					 (change-geometry (view-of *contact*)
					       :y (identification *contact*))))))
			    (:class size-property-field
					  :name :height
					  :label "height:" :value-width 40
					  :read-function contact-height
				  :write-function change-window-height)))
			  (:class bold-resource-field
				  :label "border width:"
				  :name :border-width
			   :read-function contact-border-width
			   :write-function change-window-border-width
			   :value-part
			   (:class hyper-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"))))
			  (:class bold-text-dispel
				  :name :Color-header
				  :text "Colors")
			  (:class hyper-property-sheet
				  :part-label-value-distance 10
				  :name :window-colors
			   :parts
			   ((:class bold-resource-field
				  :name background-color
				  :label "background:" :value-width 120
				  :value-class background-palette-dispel
				  :value-part (:min-width 120)
				  :read-function contact-background
				  :write-function change-window-background
				  :output-transformation
				  bg-output-transformation)
			  (:class bold-resource-field
				  :name foreground
				  :label "foreground:" :value-width 120
				  :value-class pixel-palette-dispel
				  :value-part (:min-width 120)
				  :read-function foreground
				  :write-function change-window-foreground
				  :output-transformation
				  bg-output-transformation)
			  (:class bold-resource-field
				  :name window-border-color
				  :label "border:" :value-width 120
				  :value-class pixel-palette-dispel
				  :value-part (:min-width 120)
				  :write-function
				  hyper-change-window-border-color
				  :output-transformation
				  bg-output-transformation)))
			  (:class soft-button
			   :name :save-button
				  :text-part (:text "Save")
				  :action-docu "Save all changes to resource file."
				  :action (call :eval
						(unwind-protect
						    (progn
						      (setf (inverse? *contact*) t)
						(write-class-resources-file
						     (part-of *contact*)))
						  (setf (inverse? *contact*) nil))))
			  (:class bold-resource-field
			   :name :filename
			   :label "resource-file:"
			   :value-class filename-dispel
			   :value-part (:min-width 120
					:pathname "resources.lisp")
			   :reactivity-entries
			   ((:write-event
			     (call :eval (setf (output-file (part-of *contact*))
					     (identification *contact*)))))))
		 :layouter '(pane-layouter
		   :configuration configuration-1
		   :configurations
		   ((configuration-2
		     ((:title :ask)
		      (:space 3)
		      (:select-window 30)
		      (:space 3)
		      (name-class 30 :h
				  (:name :even)
				  (space 10)
				  (:window-class :even))
		      (:space 3)
		      (resources :rest :h
				 (:Sizes :even :v
					 (head1 (:ask :size-header) :h
						(:size-header :ask)
						(rest1 :rest))
					 (space 7)
					 (x-y-w-h 60 :h
					      (:window-x-width :even)
					      (:window-y-height :even)) 
					 (:border-width :rest))
				 (space 10)
				 (:colors :even :v
					  (head2 (:ask :color-header) :h
						 (:color-header :ask) 
						 (rest2 :rest))
					  (space 7)
					  (:window-colors :rest)))
		      (space 3)
		      (button-line 30 :h
				   (:save-button :ask)
				   (space 10)
				   (:filename :rest))
		     ))
		    (configuration-1
		     ((:title :ask)
		      (:space 3)
		      (:select-window 30)
		      (:space 3)
		      (name-class 30 :h
				  (:name :even)
				  (:window-class :even))
		      (empty :rest)))))))
