anchor.diff:  	  (t (setf (gethash key *color-hash-table*)
   		   (make-instance 'named-color :name name :red red :green green :blue blue))))))
   
  -;;; For ihs to rgb conversion, we use the formula 
  -;;;  i = (r+g+b)/3
  -;;;  s = 1-min(r,g,b)/i
  -;;;  h =     60(g-b)/(max(r,g,b)-min(r,g,b)) if r >= g,b
  -;;;      120+60(b-r)/(max(r,g,b)-min(r,g,b)) if g >= r,b
  -;;;      240+60(r-g)/(max(r,g,b)-min(r,g,b)) if b >= r,g
  -;;; First, we introduce colors x, y, z such that x >= y >= z
  -;;; We compute x, y, and z and then determine the correspondance
  -;;; between x, y, and z on the one hand and r, g, and b on the other. 
  +;;;    ;;; For ihs to rgb conversion, we use the formula 
  +;;;    ;;;  i = (r+g+b)/3
  +;;;    ;;;  s = 1-min(r,g,b)/i
  +;;;    ;;;  h =     60(g-b)/(max(r,g,b)-min(r,g,b)) if r >= g,b
  +;;;    ;;;      120+60(b-r)/(max(r,g,b)-min(r,g,b)) if g >= r,b
  +;;;    ;;;      240+60(r-g)/(max(r,g,b)-min(r,g,b)) if b >= r,g
  +;;;    ;;; First, we introduce colors x, y, z such that x >= y >= z
  +;;;    ;;; We compute x, y, and z and then determine the correspondance
  +;;;    ;;; between x, y, and z on the one hand and r, g, and b on the other. 
  +;;;    (defun make-ihs-color (i h s)
  +;;;      (assert (and (<= 0 i 1)
  +;;;                 (<= 0 s 1)
  +;;;                 (<= 0 h 360)))
  +;;;      (let ((ah (/ (abs (cond ((<= h 60) h)
  +;;;                            ((<= h 180) (- h 120))
  +;;;                            ((<= h 300) (- h 240))
  +;;;                            (t (- h 360))))
  +;;;                 60)))
  +;;;        (let* ((z (* i (- 1 s)))
  +;;;             (y (/ (+ (* ah (- (* 3 i) (* 2 z))) z) (+ 1 ah)))
  +;;;             (x (- (* 3 i) y z)))
  +;;;          (assert (and (<= 0 x 1)
  +;;;                     (<= 0 y 1)
  +;;;                     (<= 0 z 1)))
  +;;;          (cond ((<= h 60) (make-rgb-color x y z))
  +;;;              ((<= h 120) (make-rgb-color y x z))
  +;;;              ((<= h 180) (make-rgb-color z x y))
  +;;;              ((<= h 240) (make-rgb-color z y x))
  +;;;              ((<= h 300) (make-rgb-color y z x))
  +;;;              (t (make-rgb-color x z y))))))
  +;;;    
  +;;;    (defmethod color-ihs ((color color))
  +;;;      (multiple-value-bind (r g b) (color-rgb color)
  +;;;        (let ((max (max r g b))
  +;;;            (min (min r g b))
  +;;;            (intensity (/ (+ r g b) 3)))
  +;;;          (if (= max min)
  +;;;            (values intensity 0 0)
  +;;;            (let* ((saturation (- 1 (/ min intensity)))
  +;;;                   (diff (- max min))
  +;;;                   (hue (* 60 (cond ((= max r) (/ (- g b) diff))
  +;;;                                    ((= max g) (+ 2 (/ (- b r) diff)))
  +;;;                                    (t (+ 4 (/ (- r g) diff)))))))
  +;;;              (when (< hue 0)
  +;;;                (incf hue 360))
  +;;;	    (values intensity hue saturation))))))
  +
  +;;;
  +;;; Below is a literal translation from Dylan's DUIM source code,
  +;;; which was itself probably literal translation from some Lisp code.
  +;;;
  +
  +(defconstant +ihs-rgb-c1+ (sqrt (coerce 1/6 'double-float)))
  +(defconstant +ihs-rgb-c2+ (sqrt (coerce 1/2 'double-float)))
  +(defconstant +ihs-rgb-c3+ (sqrt (coerce 1/3 'double-float)))
  +
  +(defun ihs-to-rgb (intensity hue saturation)
  +  (let* ((hh (- (* (mod (- hue 1/2) 1) 2 pi) pi))
  +         (c3 (cos saturation))
  +         (s3 (sin saturation))
  +         (cos-hh (cos hh))
  +         (sin-hh (sin hh))
  +         (x (* +ihs-rgb-c1+ s3 cos-hh intensity))
  +         (y (* +ihs-rgb-c2+ s3 sin-hh intensity))
  +         (z (* +ihs-rgb-c3+ c3 intensity)))
  +    (values (max 0 (min 1 (+ x x z)))
  +            (max 0 (min 1 (+ y z (- x))))
  +            (max 0 (min 1 (- z x y))))))
  +
  +(defun rgb-to-ihs (red green blue)
  +  (let* ((x (* +ihs-rgb-c1+ (- (* 2 red) blue green)))
  +         (y (* +ihs-rgb-c2+ (- green blue)))
  +         (z (* +ihs-rgb-c3+ (+ red green blue)))
  +         (q (+ (* x x) (* y y)))
  +         (intensity (sqrt (+ q (* z z))))) ;sqrt(r^2 + g^2 + b^2)
  +    (if (zerop q)
  +        ;; A totally unsaturated color
  +        (values intensity 0 0)
  +      (let* ((hue (mod (/ (atan y x) (* 2 pi)) 1))
  +             (f1 (/ z intensity))
  +             (f2 (sqrt (- 1 (* f1 f1))))
  +             (saturation (atan f2 f1)))
  +        (values intensity hue saturation)))))
  +
  +(defmethod color-ihs ((color color))
  +  (multiple-value-call #'rgb-to-ihs (color-rgb color)))
  +
   (defun make-ihs-color (i h s)
  -  (assert (and (<= 0 i 1)
  -	       (<= 0 s 1)
  -	       (<= 0 h 360)))
  -  (let ((ah (/ (abs (cond ((<= h 60) h)
  -			  ((<= h 180) (- h 120))
  -			  ((<= h 300) (- h 240))
  -			  (t (- h 360))))
  -	       60)))
  -    (let* ((z (* i (- 1 s)))
  -	   (y (/ (+ (* ah (- (* 3 i) (* 2 z))) z) (+ 1 ah)))
  -	   (x (- (* 3 i) y z)))
  -      (assert (and (<= 0 x 1)
  -		   (<= 0 y 1)
  -		   (<= 0 z 1)))
  -      (cond ((<= h 60) (make-rgb-color x y z))
  -	    ((<= h 120) (make-rgb-color y x z))
  -	    ((<= h 180) (make-rgb-color z x y))
  -	    ((<= h 240) (make-rgb-color z y x))
  -	    ((<= h 300) (make-rgb-color y z x))
  -	    (t (make-rgb-color x z y))))))
  -
  -(defun make-gray-color (intensity)
  -  (make-rgb-color intensity intensity intensity))
  -
  -(defmethod color-rgb ((color color))
  -  (with-slots (red green blue) color
  -    (values red green blue)))
  -
  -(defmethod color-ihs ((color color))
  -  (multiple-value-bind (r g b) (color-rgb color)
  -    (let ((max (max r g b))
  -	  (min (min r g b))
  -	  (intensity (/ (+ r g b) 3)))
  -      (if (= max min)
  -	  (values intensity 0 0)
  -	  (let* ((saturation (- 1 (/ min intensity)))
  -		 (diff (- max min))
  -		 (hue (* 60 (cond ((= max r) (/ (- g b) diff))
  -				  ((= max g) (+ 2 (/ (- b r) diff)))
  -				  (t (+ 4 (/ (- r g) diff)))))))
  -	    (when (< hue 0)
  -	      (incf hue 360))
  -	    (values intensity hue saturation))))))
  +  (multiple-value-call #'make-rgb-color (ihs-to-rgb i h s)))
  +
   
   (defun make-contrasting-inks (n &optional k)
     (declare (special +contrasting-colors+))
  
positive.code: 		  (format out "~%           )))~%")
  	     ))))
  
  |#
  
negative.code: 
  (in-package :CLIM-INTERNALS)
  
  (define-protocol-class design ())
  
  ;; Some internal superclasses:
  
  (define-protocol-class uniform-design () ())
  
  ;;; Color class
  
  (define-protocol-class color (design uniform-design))
  
  (defmethod print-object ((color color) stream)
    (print-unreadable-object (color stream :identity nil :type t)
      (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color))))
  
  ;;; standard-color
  
  (defclass standard-color (color)
    ((red   :initarg :red
            :initform 0
            :type (real 0 1))
     (green :initarg :green
            :initform 0
            :type (real 0 1))
     (blue  :initarg :blue
            :initform 0
            :type (real 0 1))))
  
  (defmethod color-rgb ((color standard-color))
    (with-slots (red green blue) color
      (values red green blue)))
  
  (defclass named-color (standard-color)
    ((name :initarg :name
  	 :initform "Unnamed color") ))
  
  (defmethod print-object ((color named-color) stream)
    (with-slots (name) color
      (print-unreadable-object (color stream :type t :identity nil)
        (format stream "~S" name))))
  
  (defvar *color-hash-table* (make-hash-table :test #'eql))
  
  