anchor.diff:      (or (gethash key *color-hash-table*)
   	(setf (gethash key *color-hash-table*)
   	      (make-instance 'named-color :red red :green green :blue blue)))))
  +
  +(defun make-gray-color (intensity)
  +  (make-rgb-color intensity intensity intensity))
   
   (defun make-named-color (name red green blue)
     (let* ((key (compute-color-key red green blue))
  
positive.code: 	  (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. 
  (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))))))
  
  (defun make-contrasting-inks (n &optional k)
    (declare (special +contrasting-colors+))
  
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))
  
  