;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Color sliders Examples
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/color-sheet.lisp
;;; File Creation Date: 09/14/90 10:33:57
;;; Last Modification Time: 10/08/92 16:46:39
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 05/22/1992 (Juergen)  The color-sheet is no longer created in this file.
;;;                       This should be done seperately.
;;; 10/08/1992 (Matthias) added focus-mixin to color-sheet
;;;_____________________________________________________________________________

;; Usage: 
;; (setq *color-sheet* (make-window 'color-sheet-window))
;; (specify-color-value *color-sheet*
;;         :window demo-window
;;         :color-reader :background
;;         :initial-value "red"
;;

(in-package :xit)

;;;_______________________________________________________________
;;;
;;;  Some slider modifications
;;;_______________________________________________________________

(defclass active-slider-mixin ()
  ((value :reader slider-value)))

(defmethod (setf slider-value) :after (new-value (self active-slider-mixin))
  (with-slots (value) self
    (setf value new-value)))

(defcontact basic-color-slider (active-slider-mixin numerical-slider)
  ((width :initform 60)
   (height :initform 120)
   (max :initform 1)
   (min :initform 0)))

(defmethod move-slider-knob-before ((self basic-color-slider) knob-position)
  (declare (ignore knob-position))
  (set-window-color (view-of self)))

(defmethod move-slider-knob-after ((self basic-color-slider) knob-position)
  (declare (ignore knob-position))
  (reset-window-color (view-of self)))     

(defmethod move-slider-knob :before ((self active-slider-mixin) knob-position)
  (with-slots (value) self
    (setf value (compute-slider-value self knob-position))))

(defcontact color-slider (basic-color-slider)
  ((color-slot :type (member red blue green) :initarg :color-slot
	       :reader color-slot)))

(defmethod move-slider-knob ((self color-slider) knob-position)
  (declare (ignore knob-position))
  (update-rgb-color (view-of self) (color-slot self) (slider-value self)))

(defcontact hsb-slider (basic-color-slider)
  ((hsb-slot :type (member hue brightness saturation) :initarg :hsb-slot
	     :reader hsb-slot)))

(defmethod move-slider-knob ((self hsb-slider) knob-position)
  (declare (ignore knob-position))
  (update-hsb-color (view-of self) (hsb-slot self) (slider-value self)))

;;;----------------------------------------------------------------------
;;;
;;;

(defcontact rgb (intel)
  ((name :initform 'rgb)
   (border-width :initform 1) 
   (layouter :initform '(distance-layouter :distance 5 :orientation :right)))) 
		      
(defmethod initialize-instance :after ((self rgb) &rest initargs)
  (add-part self :class  'captioned-slider
   :name :red
   :labelled-slider-part
   `(:class text-labelled-slider
	    :high-label-part (:text "max")
		     :low-label-part (:text "min")
		     :slider-part (:class color-slider
			  :knob-part (:background "red" :width 37 :height 15 
				      :move-immediate? nil)
			  :color-slot red))
   :caption-part '(:text "Red"))
  (add-part self :class  'captioned-slider
  :name :green
			      :labelled-slider-part
			      `(:class text-labelled-slider
	    :high-label-part (:text "max")
		     :low-label-part (:text "min")
		     :slider-part (:class color-slider
					      :knob-part (:background "green"
							  :width 37 :height 15 
				      :move-immediate? nil)
					      :color-slot green))
			      :caption-part '(:text "Green"))
  (add-part self :class  'captioned-slider
  :name :blue
			      :labelled-slider-part
			      `(:class text-labelled-slider
	    :high-label-part (:text "max")
		     :low-label-part (:text "min")
		     :slider-part (:class color-slider
					      :knob-part (:background "blue"
				                          :width 37 :height 15 
				      :move-immediate? nil)
					      :color-slot blue))
			      :caption-part '(:text "Blue")))


(defcontact hsb (intel)
  ((name :initform 'hsb)
   (border-width :initform 1)
   (layouter :initform '(distance-layouter :distance 5 :orientation :right)))) 
		      
(defmethod initialize-instance :after ((self hsb) &rest initargs)
  (add-part self :class  'captioned-slider
	    :name :hue
	    :labelled-slider-part
	    `(:class text-labelled-slider
		     :high-label-part (:text "red-blue")
		     :low-label-part (:text "green-red")
		     :slider-part (:class hsb-slider
				 :max .99999
				   :knob-part (:move-immediate? nil
					       :width 37 :height 15)
				   :hsb-slot hue))
	    :caption-part '(:text "Hue"))
  (add-part self :class  'captioned-slider
	    :name :saturation
	    :labelled-slider-part
	    `(:class text-labelled-slider
		     :high-label-part (:text "color")
		     :low-label-part (:text "b/w")
	    :slider-part (:class hsb-slider
				   :knob-part (:move-immediate? nil
					       :width 37 :height 15)
				   :hsb-slot saturation))
	    :caption-part '(:text "Saturation"))
  (add-part self :class  'captioned-slider
	    :name :brightness
	    :labelled-slider-part
	    `(:class text-labelled-slider
		     :high-label-part (:text "bright")
		     :low-label-part (:text "dark")
	    :slider-part (:class hsb-slider
				   :knob-part (:move-immediate? nil
					       :width 37 :height 15)
				   :hsb-slot brightness))
	    :caption-part '(:text "Brightness")))





(defclass color-control-hsb-mixin ()
  ((hsb :type hsb :reader hsb)
   (hue :accessor hue :initform 0)
   (saturation :accessor saturation :initform 0)
   (brightness :accessor brightness :initform 0)))
   
(defmethod hue-slider ((self color-control-hsb-mixin))
  (part (part (part (hsb self) :hue) :labelled-slider) :slider))

(defmethod saturation-slider ((self color-control-hsb-mixin))
  (part (part (part (hsb self)  :saturation) :labelled-slider) :slider))

(defmethod brightness-slider ((self color-control-hsb-mixin))
  (part (part (part (hsb self) :brightness) :labelled-slider) :slider))


(defclass color-control-rgb-mixin ()
  ((rgb :type rgb :reader rgb)
   (red :accessor red :initform 0)
  (blue :accessor blue :initform 0)
  (green :accessor green :initform 0)
  ))

(defmethod red-slider ((self color-control-rgb-mixin))
  (part (part (part (rgb self) :red) :labelled-slider) :slider))

(defmethod green-slider ((self color-control-rgb-mixin))
  (part (part (part (rgb self) :green) :labelled-slider) :slider))

(defmethod blue-slider ((self color-control-rgb-mixin))
  (part (part (part (rgb self)  :blue) :labelled-slider) :slider))

(defmethod update-hsb-color ((self color-control-hsb-mixin) slot value)
  (setf (slot-value self slot) value)
  (with-slots (hue saturation brightness) self
     (multiple-value-bind (r g b)
	 (hsb-to-rgb hue saturation brightness)
       (change-hsb-color self r g b))))

(defmethod update-hsb-color :after ((self color-control-rgb-mixin) slot value)
  (declare (ignore slot value))
  (update-rgb self (color self)))

;;; CCC 02/07/1991 (Matthias) sorgt fuer's Verschieben der hsb-Knobs
(defmethod update-hsb-color :after ((self color-control-hsb-mixin) slot value)
  (declare (ignore slot value))
  (update-hsb self (color self)))


(defmethod (setf hue) :after (value (self color-control-hsb-mixin))
  (setf (slider-value (hue-slider self)) value))

(defmethod (setf brightness) :after (value (self color-control-hsb-mixin))
  (setf (slider-value (brightness-slider self)) value))

(defmethod (setf saturation) :after (value (self color-control-hsb-mixin))
  (setf (slider-value (saturation-slider self)) value))

(defmethod update-hsb ((self color-control-hsb-mixin) color)
  (multiple-value-bind (h s b)
      (rgb-to-hsb (color-red color) (color-green color) (color-blue color))
    (setf (hue self) (or h (hue self)))
    (setf (saturation self) (or s (saturation self)))
    (setf (brightness self) (or b (brightness self)))))
      
(defmethod update-rgb-color ((self color-control-rgb-mixin) slot value)
  (setf (slot-value self slot) value)
  (with-slots (red green blue) self
    (change-rgb-color self red green blue)))

(defmethod update-rgb-color :after ((self color-control-hsb-mixin) slot value)
  (declare (ignore slot value))
  (update-hsb self (color self)))

;;; CCC 02/07/1991 (Matthias) sorgt fuer's Verschieben der rgb-Knobs
(defmethod update-rgb-color :after ((self color-control-rgb-mixin) slot value)
  (declare (ignore slot value))
  (update-rgb self (color self)))


(defmethod (setf red) :after (value (self  color-control-rgb-mixin))
  (setf (slider-value (red-slider self)) value))

(defmethod (setf blue) :after (value (self  color-control-rgb-mixin))
  (setf (slider-value (blue-slider self)) value))

(defmethod (setf green) :after (value (self  color-control-rgb-mixin))
  (setf (slider-value (green-slider self)) value))

(defmethod update-rgb ((self  color-control-rgb-mixin ) color)
  (setf (red self) (color-red color))
  (setf (blue self) (color-blue color))
  (setf (green self) (color-green color)))
  
(defclass color-control-mixin ()
  ((color :accessor color :initform (make-color))
  (colormap :initform (screen-default-colormap *screen*)
	    :accessor colormap
	    :initarg colormap)
  (pixel :accessor pixel :initform nil)
  ;; old-pixel holds the old window color to allow undo (not for border)
  (old-pixel :accessor old-pixel :initform nil)
  (exact-color? :initform nil :accessor exact-color? :initarg :exact-color?)
  (window :type basic-window :initarg :window :accessor color-window)
  (color-reader :initarg :color-reader
			 :accessor color-reader
			 :initform 'background-color)
  (color-writer :initarg :color-writer
			 :accessor color-writer
			 :initform 'change-window-background)
  ))

(defmethod print-object ((self color-control-hsb-mixin) (stream t))
  (format stream "#<COLOR-CONTROL: Hue ~,5F, Saturation: ~,5F, Brightness ~,5F>"
	  (hue self) (saturation self) (brightness self)))
  
(defmethod print-object ((self color-control-rgb-mixin) (stream t))
  (format stream "#<COLOR-CONTROL: Red ~,5F, Green ~,5F, Blue ~,5F>"
	  (red self) (green self) (blue self)))

(defmethod (setf color-reader) :before (value (self  color-control-mixin))
  (freeze-color self)) 

(defmethod (setf color-reader) :around (value (self  color-control-mixin))
  (funcall #'call-next-method
	 (case value
	   ((contact-background background) 'background-color)
	   (t value)) self))
  
(defmethod (setf color-writer) :after (value (self  color-control-mixin))
  (declare (ignore value))
  (get-color-from-window self))

(defmethod (setf color-reader) :after (value (self  color-control-mixin))
  (with-slots (window) self
    (setf (old-pixel self) (funcall value window))
    (setf (color-writer self) 
	(cond ((eq value 'background-color) 'change-window-background)
	      ((eq value 'window-border-color) 'change-window-border-color)
	      ((eq value 'foreground) 'change-window-foreground))))
  (let ((menu (part (view self) :part-menu)))
    (when menu (read-from-application menu)))
  )

(defmethod window-border-color ((self contact))
  (convert self "black" 'pixel))

(defmethod background-color ((self contact))
  (let ((bg (background self)))
    (if (typep bg 'pixel) bg
      (convert self "grey" 'pixel))))

(defmethod change-window-border-color ((self contact) color)
  (setf (window-border self) color))

(defmethod get-color-from-window ((self color-control-mixin))
  (with-slots (window colormap color-reader) self
    (let* ((pixel (funcall color-reader window))
	   (color (car (query-colors colormap
				    (list pixel)))))
      (setf (color self) color)
      ;(display-color self pixel)
      color)))

(defmethod freeze-color ((self color-control-mixin))
  (with-slots (colormap pixel color-writer window color) self
    (when pixel
      (free-colors colormap (list pixel))
      (setf pixel nil)
      (funcall color-writer window
	     (convert window
		      color 'pixel)))))

(defmethod (setf color-window) :after (value (self  color-control-mixin))
  (declare (ignore value))
  (display-colors self)
  (let ((color-field (part* (view self) :cw :color-field))
	(color-window-identifier (part* (view self) :cw :color-window-identifier))
	(menu (part (view self) :part-menu)))
    (when color-field (read-from-application color-field))
    (when color-window-identifier (read-from-application color-window-identifier))
    (when menu (setf (color-reader self) (selection menu))))
  ; CCC done after setf color-reader (get-color-from-window self)
  )

(defmethod (setf color-window) :before (value (self  color-control-mixin))
  (freeze-color self) 
  (let ((sensitive-parts nil)
	(menu (part (view self) :part-menu)))
    (when menu
      (flet ((sensitive-on (part-name)
	       (let ((menu-part (part menu part-name)))
		 (setf (contact-sensitive menu-part) :on)
		 (setf (shaded? menu-part) nil)
		 (pushnew (view-of menu-part) sensitive-parts)))
	     (sensitive-off (part-name)
	       (let ((menu-part (part menu part-name)))
		 (setf (contact-sensitive menu-part) :off)
		 (setf (shaded? menu-part) t))))
	(sensitive-off :foreground)
	(sensitive-off :background)
	(sensitive-off :border)
	(when (typep value 'contact)
	  (sensitive-on :background)
	  (sensitive-on :border))
	(when (typep value 'foreground-color-mixin)
	  (sensitive-on :foreground))
	(unless (member (identification menu) sensitive-parts)
	  (setf (identification menu) (car sensitive-parts)))))))

(defmethod (setf color) :after (value (self color-control-hsb-mixin))
  (update-hsb self value))

(defmethod (setf color) :after (value (self color-control-rgb-mixin))
  (update-rgb self value))

(defmethod (setf color) :after (value (self color-control-mixin))
  (update-color-name self)
  (update-window-color self value))

(defmethod update-window-color ((self color-control-mixin) value)
  (with-slots (pixel colormap window color-writer) self
    (cond (pixel
	(xlib::store-color colormap pixel value))
      ((realized-p window)
       (let ((pix (convert window value 'pixel)))
	 (funcall  color-writer
		   window pix)
	 (display-color self pix))))))

(defmethod update-color-name ((self color-control-mixin))
  (let ((color-field (part* (view self) :cw :color-field)))
    (when color-field (setf (value color-field) (color self)))))
    
(defmethod change-rgb-color ((self color-control-rgb-mixin) red green blue)
  (with-slots (color) self
    (setf color (make-color :red (or red (color-red color))
			    :green (or green (color-green color))
			    :blue (or blue (color-blue color))))
    (update-window-color self color)))

(defmethod change-rgb-color :after ((self color-control-hsb-mixin) red green blue)
  (declare (ignore red green blue))
  (update-hsb self (color self)))
  
(defmethod change-hsb-color ((self color-control-hsb-mixin) red green blue)
  (with-slots (color) self
    (setf color (make-color :red (or red (color-red color))
			    :green (or green (color-green color))
			    :blue (or blue (color-blue color))))
    (update-window-color self color)))

(defmethod change-hsb-color :after ((self color-control-rgb-mixin)  red green blue)
  (declare (ignore red green blue))
  (update-rgb self (color self)))
  


#|| CCC Todo Brightness proportional zu farbenhelligkeit

Mittler Farbe springt gern.
(defun hsb-to-rgb (h s b)
  (multiple-value-bind (hue-red hue-green hue-blue)
      (hue-rgb h)
    (let* ((red (- 1 (* s (- 1 hue-red))))
	   (blue (- 1 (* s (- 1 hue-blue))))
	   (green (- 1 (* s (- 1 hue-green))))
	   (average (/ (+ red blue green) 3))
	   (factor 0))
      (cond ((= average 1) (values b b b))
	    ((< average b)
	     (setq factor (/ (- 1 b) (- 1 average)))
	     (values
	      (round-rgb (- 1 (* factor (- 1 red))))
	      (round-rgb (- 1 (* factor (- 1 green))))
	      (round-rgb (- 1 (* factor (- 1 blue))))))
	    (t
	     (setq factor (/ b  average))
	     (values
	      (round-rgb (* factor red))
	      (round-rgb (* factor green))
	      (round-rgb (* factor blue))))))))

(defun rgb-to-hsb (red green blue)
  (let* ((b (round-rgb (/ (+ red green blue) 3)))
	 (s (if (zerop b) nil (round-rgb (- 1 (/ (min red green blue) b))))))
    (cond ((= b 0) (values nil nil 0))
	  ((= 1 blue green red) (values nil nil 1))
	  ((= s 0) (values nil 0 b))
	  ((<= blue green red)
	   (values (round-rgb (/ (saturated green s b) 6)) s b))
	  ((<= blue red green)
	   (values (round-rgb (/ (- 2 (saturated  red s b)) 6))  s b))
	  ((<= red blue green)
	   (values (round-rgb (/ (+ 2 (saturated  blue s b)) 6))  s b))
	  ((<= red green blue)
	   (values (round-rgb (/ (- 4 (saturated  green s b)) 6))  s b))
	  ((<= green red blue)
	   (values (round-rgb (/ (+ 4 (saturated red s b)) 6))  s b))
	  ((<= green blue red)
	   (values (round-rgb (/ (- 6 (saturated blue s b)) 6))  s b)))))
(defun rgb-to-hsb (red green blue)
  (let* ((b (round-rgb (/ (+ red green blue) 3)))
	 (s (* 2 (min red green blue (- 1 red) (- 1 green) (- 1 blue)))))
    (cond ((= b 0) (values nil nil 0))
	  ((= 1 blue green red) (values nil nil 1))
	  ((= s 0) (values nil 0 b))
	  ((<= blue green red)
	   (values (round-rgb (/ (saturated green s b) 6)) s b))
	  ((<= blue red green)
	   (values (round-rgb (/ (- 2 (saturated  red s b)) 6))  s b))
	  ((<= red blue green)
	   (values (round-rgb (/ (+ 2 (saturated  blue s b)) 6))  s b))
	  ((<= red green blue)
	   (values (round-rgb (/ (- 4 (saturated  green s b)) 6))  s b))
	  ((<= green red blue)
	   (values (round-rgb (/ (+ 4 (saturated red s b)) 6))  s b))
	  ((<= green blue red)
	   (values (round-rgb (/ (- 6 (saturated blue s b)) 6))  s b)))))
||# 
(defun hsb-to-rgb (h s b)
  (multiple-value-bind (hue-red hue-green hue-blue)
      (hue-rgb h)
    (values
     (round-rgb (* b (- 1 (* s (- 1 hue-red)))))
     (round-rgb (* b (- 1 (* s (- 1 hue-green)))))
     (round-rgb (* b (- 1 (* s (- 1 hue-blue))))))))

(defun rgb-to-hsb (red green blue)
  (let* ((b (round-rgb (max red green blue)))
	(s (if (zerop b) nil (round-rgb (- 1 (/ (min red green blue) b))))))
    (cond ((= b 0) (values nil nil 0))
	  ((= 1 blue green red) (values nil 0 1))
	  ((= s 0) (values nil 0 b))
	  ((<= blue green red)
	   (values (round-rgb (/ (saturated green s b) 6)) s b))
	  ((<= blue red green)
	   (values (round-rgb (/ (- 2 (saturated red  s b)) 6))  s b))
	  ((<= red blue green)
	   (values (round-rgb (/ (+ 2 (saturated blue  s b)) 6))  s b))
	  ((<= red green blue)
	   (values (round-rgb (/ (- 4 (saturated green  s b)) 6))  s b))
	  ((<= green red blue)
	   (values (round-rgb (/ (+ 4 (saturated red  s b)) 6))  s b))
	  ((<= green blue red)
	   (values (round-rgb (/ (- 6 (saturated blue  s b)) 6))  s b)))))

(defun round-rgb (rgb &optional (divisor 100))
  (float rgb))
	  
(defun saturated (middle saturation brightness)
  (- 1 (/ (- 1 (/ middle brightness)) saturation)))
     
(defun hue-rgb (hue)
   (let* ((hue6 (* hue 6))
	  (red (filter-rgb (- (abs (- hue6 3)) 1)))
	  (blue (filter-rgb (- 2 (abs (- hue6 4)))))
	  (green (filter-rgb (- 2 (abs (- hue6 2))))))
     (values red green blue)))

(defun filter-rgb (x)
  (max 0 (min 1 x)))

(defun pixel-to-color (px &key colormap)
  (declare (special *screen*))
  (ignoring-errors
   (car (query-colors (or colormap
			   (screen-default-colormap *screen*))
		       (list px)))))

(defvar *color-allocation-error* nil)

(defmethod set-window-color ((self color-control-mixin))
  (declare (special *screen* *color-allocation-error*))
  (with-slots (window pixel colormap color color-reader color-writer) self
    (unless pixel
    (setf colormap (screen-default-colormap *screen*))
    (let* (; (old-pixel (funcall color-reader window))
	   ;; CCC don't needed
	   (pix (ignoring-errors (car (alloc-color-cells colormap 1))))
	 ;(color (pixel-to-color old-pixel))
	 )
      (cond (pix (setq *color-allocation-error* nil)
	     (store-color colormap pix color)
		 (funcall color-writer window pix)
		 (display-color self pix)
		 (setf pixel  pix)
		 (setf (color self) color)
		 pix)
	    (t (unless *color-allocation-error*
		 (setq *color-allocation-error* t)
	     (warn "~
If you are using a b/w screen, ask your manager to buy you~%a color screen. ~
Otherwise, it is a good idea to switch to b/w."))))))))

(defmethod reset-window-color ((self color-control-mixin))
  (declare (special *screen*))
  (with-slots (window pixel colormap color-writer) self
    (cond (pixel
      (let* ((color (pixel-to-color pixel))
	     (color-name (get-color-name color)))
	(update-color-name self)
	(unless (exact-color? self)
	  (setf color (convert window color-name 'color))
	  (setf (color self) color))
	))
	  (t (update-color-name self)))))

(defmethod display-color ((self color-control-mixin) pixel)
  (let ((color-dispel (part (view self) :color-dispel)))
    (when (and color-dispel (realized-p color-dispel))
      (funcall (color-writer self) color-dispel pixel))))

(defmethod display-colors ((self color-control-mixin))
  (let ((color-dispel  (part (view self) :color-dispel)))
    (when (and color-dispel (realized-p color-dispel))
      (display-colors-in-color-dispel (color-window self) color-dispel))))

(defmethod display-colors-in-color-dispel ((color-window t) color-dispel)
  nil)

(defmethod display-colors-in-color-dispel ((color-window contact) color-dispel)
  (change-window-background color-dispel (background color-window))
   (change-window-border-color color-dispel (window-border-color
					      color-window))
   (when (next-method-p)
     (call-next-method)))
    
(defmethod display-colors-in-color-dispel ((color-window foreground-color-mixin)
					   color-dispel)
  (change-window-foreground color-dispel (foreground color-window))
  (when (next-method-p)
     (call-next-method)))
    


;;;-------------------------------------------------------------------------
;;; Color Slider Pane
;;;-------------------------------------------------------------------------

;;; CCC
(defcontact color-sheet-window (focus-mixin popup-part-connection paned-window)
  ((name :initform :example-paned-window)
   (popup-part :initform :default)
   (reactivity :initform '((:single-left-button "Totop Window" (call :totop))
			   (:single-middle-button "Move Window" (call :move))
			   (:single-right-button "Menu" (call :popup-part))))))



(defmethod default-window-popup-menu ((self color-sheet-window))
  (make-window 'popup-text-menu
	       :parent (toplevel-window self)
	       :view-of self
	       :inside-border 10
	       :reactivity '((:part-event (call :eval (funcall *part-value* (view-of *contact*)))))
	       :parts '((:view-of update
			 :text "refresh"
			 :action-docu "Refresh window")
			(:view-of move-window
			 :text "move"
			 :action-docu "Move window")
			(:view-of totop-window
			 :text "totop"
			 :action-docu "Put window on top")
			(:view-of tobottom-window
			 :text "tobottom"
			 :action-docu "Put window to bottom")
			(:view-of bury-window
			 :text "close"
			 :action-docu "Close window"))))


(defclass color-control (view-mixin color-control-rgb-mixin color-control-hsb-mixin
			 color-control-mixin)
  ())

(defmethod print-object ((self color-control) (stream t))
  (format stream
	  "#<COLOR-CONTROL: Red ~,5F, Green ~,5F, Blue ~,5F~
         ~%                 Hue ~,5F, Saturation: ~,5F, Brightness ~,5F> "
	  (red self) (green self) (blue self)
	  (hue self) (saturation self) (brightness self)))

(defcontact cs-single-choice-text-menu (single-choice-text-menu)
  ())

(defmethod sensitivity-changed ((self cs-single-choice-text-menu))
  nil)

(defcontact cs-bold-property-field (bold-property-field)
  ())

(defmethod sensitivity-changed ((self cs-bold-property-field))
  nil)

(defun make-color-sheet (&optional (parent *toplevel*)
			 &key (window-editable? t) (menu-editable? t)
			      (title? t)
			      (color-bitmap  "druid5")
			      (colormap (window-colormap *root*))
			      (default-update-documentation
			       "Insert this color into application"))
  (let ((control (make-instance 'color-control :window *toplevel*
				:colormap colormap))
	(color-sheet nil))
      (setq color-sheet (make-window
       'color-sheet-window
       :name :color-sheet
       :adjust-size? nil
       :state :managed
       :view-of control
       :window-icon-pos :window 
       :background "gray95"
       :border-width 2
       :inside-border 3
       :x 10
       :y 30
       :width 480
       :height 310
       :parts `((:class bold-text-dispel
			    :name :title
			    :adjust-size? nil
			    :background "black"
			    :foreground "white"
			    :text "Color Sheet")			  
		(: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-width 120
			   :value-class color-identifier
			   :value-part (:min-width 120)
			   :read-function color)
		   (:class cs-bold-property-field
			   :name :color-window-identifier
			   :label "window:"
			   :sensitive ,(if window-editable? :on :off)
			   :read-function color-window
			   :value-class window-identifier-dispel
			   :value-part ,(if window-editable? () '(:border-width 0)))))
		(:class bitmap-dispel
		 :name :color-dispel
		 :bitmap ,color-bitmap
		 :border-width 5)
		(:class soft-button
		 :name :ok-button
		 :text-part (:text "OK")
		 :bitmap-part (:bitmap "button-m")
		 :action-docu ,default-update-documentation
		 :action
		 (call :eval (let* ((control (view-of
						    (part-of *contact*))))
			       (bury-window (part-of *contact*))
			       (send-synchronize-event (color control)))))
		(:class cs-single-choice-text-menu
			  :name :part-menu
			  :adjust-size? nil
			  :border-width 1
			  :inside-border 5
			  :sensitive ,(if menu-editable? :on :off)
			  :view-of ,control
			  :reactivity-entries
			  ((:write-event
			     (call :eval
				   (setf (color-reader (view-of *contact*))
				     (selection *contact*))))
			   (:read-event
			     (call :eval
				   (setf (identification *contact*)
				     (color-reader (view-of *contact*))))))
			  :parts ((:name :background
				    :view-of background-color
				    :text "Background Color"
				    :action-docu "Change Background Color")
				   (:name :foreground
				    :view-of foreground
				    :text "Foreground Color"
				    :action-docu "Change Foreground Color")
				   (:name :border
				    :view-of window-border-color
				    :text "Border Color"
				    :action-docu "Change Border Color"))))
		 
				     
       :layouter `(pane-layouter
		   :configuration configuration-1
		   :configurations
		   ((configuration-1
		     (,@(when title?
			  (list '(:title :ask)
				'(:space 3)))
		      (slider-strip :rest :h
				    (:rgb :even)
				    (space 3)
				    (:hsb :even))
		      (space 3)
		      (rest-strip (:ask :color-dispel) :h
				  (part-menu-field :even :h
					 (:part-menu :rest)
					 (space 3)
					 (:color-dispel (:ask :color-dispel 5)))
				  (space 3)
				  (buttons :even :v
					    (:cw 51)
					    (space :even)
					    (:ok-button-strip (:ask :ok-button) :h
						(space :even)
						(:ok-button :ask)
						(space :even)
						)
					   (space :even)
					     ))
		      ))))))
      (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)))

(defmethod specify-color-value ((self color-sheet-window)
				       &key window  colormap
				       (color-reader :background)
				       initial-value)
  "Opens the color mixer with the given initial values and returns the mixed color
 when the color mixer is closed. Notice that the result is of CLX type color. 
 So if you want the name use get-color-name, and if you want a pixel use convert.
 If a window is given, the changes may be followed in this window, it also delivers 
 an initial value (not possible for border color) if no color is given as 
 initial-value. Color-reader may be one of :background, :foreground, and :border
 (the corresponding proper reader-functions are accepted as well)."
  (with-synchronous-mode (self)
    (let ((control (view-of self)))
      (unless window
	(setq window (part self :color-dispel)))
      (setf (color-window control) window)
      (when colormap (setf (colormap control) colormap))
      (setf (color-reader control)
	   (case color-reader
	     ((background-color :background) 'background-color)
	     ((foreground :foreground) 'foreground)
	     ((window-border-color :border) 'window-border-color)))
       (multiple-value-bind (color exact-color)
	   (convert self initial-value
		    'color)
	 (setf (color control)
	     (cond (color (or exact-color color))
		   ((pixel-to-color (funcall (color-reader control) window)))
		   (t (pixel-to-color 1)))))
       (totop-window self))
     ))

(defmethod call-color-sliders ((self color-sheet-window) (window basic-contact)
			       color-reader &key update-documentation
			       update-function initial-color)
  (let* ((control (view-of self))
	 (action-docu (or update-documentation
			  (reactivity-documentation-for (part self :ok-button)
							:single-left-button)))
	 (action (and update-function
		      `(call :eval (let* ((control (view-of (part-of *contact*))))
				(funcall ',update-function (color control))
				(bury-window (part-of *contact*)))))))
    (when (or update-documentation update-function)
      (if action-docu
	(change-reactivity (part self :ok-button)
			   :single-left-button action-docu action)
      (change-reactivity (part self :ok-button)
			 :single-left-button action)))
    (setf (color-window control) window)
    (setf (colormap control) (window-colormap window))
    (setf color-reader
	(case color-reader
	 (:background 'background-color)
	 (:foreground 'foreground)
	 (:border 'window-border-color)))
    (setf (color-reader control)
	color-reader)
    (multiple-value-bind (color exact-color)
	(convert self initial-color
		 'color)
      (setf (color control)
	  (cond (color exact-color)
		((pixel-to-color (funcall color-reader window)))
		(t (pixel-to-color 1))))))
  (totop-window self))

;(setq *color-sheet* (make-color-sheet))
