;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Colors
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/color-meta.lisp
;;; File Creation Date: 10/10/91 09:58:26
;;; Last Modification Time: 07/06/92 11:00:35
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

#||
(defun destroy-color-sheet ()
  (declare (special *color-sheet*))
  (destroy-and-make-unbound *color-sheet*))

(defmethod select-color-sheet-for ((window basic-contact)
				   (prop-value-field text-dispel)
				   reader)
  (declare (special *color-sheet*))
  (unless (and (boundp '*color-sheet*) *color-sheet*)
    (setf *color-sheet* (make-color-sheet :window-editable? nil
					  :menu-editable? nil)))
  (call-color-sliders *color-sheet* window reader
		      :update-function
		      `(lambda (color) (setf (text ',prop-value-field)
					   (get-color-name color)))))
||#

(defun select-meta-color-sheet (window &key (color-reader :background))
  (declare (special *meta-pool* *white-pixel*))
  (let* ((sheet (get-pool-window *meta-pool* :meta-color-sheet))
	 (color-sheet (client-window sheet))
	 (control (view-of color-sheet))
	 (property-sheet (part color-sheet :cw))
	 (color-property-dispel (part* property-sheet :color-field :label)))
    (setf (color-window control) window)
    (setf (color-reader control)
	(case color-reader
	 (:background 'background-color)
	 (:foreground 'foreground)
	 (:border 'window-border-color)))
     (setf (color control)
	  (or (pixel-to-color (funcall (color-reader control) window))
	      (pixel-to-color *white-pixel*)))
     (setf (text color-property-dispel)
	 (case color-reader
	   (:background "background color")
	   (:foreground "foreground color")
	   (:border "border color")
	   (t "color")))
     (recompute-part-label-width property-sheet)
     (popup sheet)))

(defmethod make-meta-sheet-named ((key (eql :meta-color-sheet)))
  (while-busy nil
    (let*
      ((control (make-instance 'color-control :window *toplevel*))
       (sheet
	(make-window 'shadow-popup-margined-window
	  :name :meta-color-sheet
	  :margins 
	  '((standard-margins
	     :label-options
	     (:name :label
	      :inside-border 3
	      :text "Color Properties")
	     :quad-space-options
	     (:name :space
	      :thickness 1)))
	  :client-window 
	  `(paned-window
	    :name :color-sheet
	    :view-of ,control
	    :border-width 1
	    :inside-border 3
	    :width 470
	    :height 270
	    :parts ((:class rgb
		     :name :rgb)
		    (:class hsb
		     :name :hsb)
		    (:class property-sheet
		     :name :cw
		     :border-width 1
		     :inside-border 3
		     :parts
		     ((;;:class bold-property-field
		       :name :color-field
		       :label "color"
		       :value-part (:class color-identifier
				    :reactivity-entries ((:edit))
				    :min-width 150)
		       :read-function color))))
	    :layouter (pane-layouter
		       :configuration configuration-1
		       :configurations
		       ((configuration-1
			 ((slider-strip :rest :h
					(:rgb :even)
					(space 3)
					(:hsb :even))
			  (space 3)
			  (:cw :ask))))))))
       (color-sheet (client-window sheet)))
      (setf (view control) color-sheet)
      (setf (slot-value control 'hsb) (part color-sheet :hsb))
      (setf (slot-value control 'rgb) (part color-sheet :rgb))
      (setf (color-window control) color-sheet)
      sheet)))
  