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:       (subseq +contrasting-colors+ n)
      (aref +contrasting-colors+ k)))
  
  #|
  ;;; I used this function to generate the predefined colors and names - mikemac@mikemac.com
  
  (defun generate-named-colors ()
  
negative.code: 		  (format out "~%           )))~%")
  	     ))))
  
  ||#
  
  ;;;;
  ;;;; 13.4 Opacity
  ;;;;
  
  (define-protocol-class opacity (design))
  
  ;; Note: Though tempting, opacity is not a uniform-design!
  
  (defclass standard-opacity (opacity)
    ((value :initarg :value
            :type (real 0 1)
            :reader opacity-value)))
  
  (defvar +transparent-ink+ 
      (load-time-value (make-instance 'standard-opacity :value 0)))
  
  (defun make-opacity (value)
    (setf value (clamp value 0 1))        ;defensive programming
    (cond ((= value 0)
           +transparent-ink+)
          ((= value 1)
           +foreground-ink+)
          (t
           (make-instance 'standard-opacity :value value))))
  
  ;;;;
  ;;;; 13.6 Indirect Inks
  ;;;;
  
  (defclass indirect-ink (design) ())
  
  (defvar +foreground-ink+ (load-time-value (make-instance 'indirect-ink)))
  (defvar +background-ink+ (load-time-value (make-instance 'indirect-ink)))
  
  (defmethod print-object ((ink (eql +foreground-ink+)) stream)
    (format stream "#.~S" '+foreground-ink+))
  
  (defmethod print-object ((ink (eql +background-ink+)) stream)
    (format stream "#.~S" '+background-ink+))
  
  ;;;;
  ;;;; 13.7 Flipping Ink
  ;;;;
  
  (defclass standard-flipping-ink (design)
    ((design1 :initarg :design1
              :type design)
     (design2 :initarg :design2
              :type design)))
  
  (defvar +flipping-ink+ (load-time-value   (make-instance 'standard-flipping-ink 
                                              :design1 +foreground-ink+
                                              :design2 +background-ink+)))
  
  (defmethod print-object ((ink (eql +flipping-ink+)) stream)
    (format stream "#.~S" '+flipping-ink+))
  
  (defmethod print-object ((flipper standard-flipping-ink) stream)
    (with-slots (design1 design2) flipper
      (print-unreadable-object (flipper stream :identity nil :type t)
        (format stream "~S ~S" design1 design2))))
  
  (defmethod make-flipping-ink ((design1 design) (design2 design))
    (make-instance 'standard-flipping-ink :design1 design1 :design2 :design2))
  
  (defmethod make-flipping-ink ((design1 (eql +foreground-ink+)) 
                                (design2 (eql +background-ink+)))
    +flipping-ink+)
  
  (defmethod make-flipping-ink ((design1 (eql +background-ink+)) 
                                (design2 (eql +foreground-ink+)))
    +flipping-ink+)
  
  ;;;;
  ;;;; 14 General Designs
  ;;;;
  
  (defgeneric compose-over (design1 design2))
  (defgeneric compose-in (ink mask))
  (defgeneric compose-out (ink mask))
  
  (defclass pattern (design)
    ((array :initarg :array)
     (designs :initarg :designs)))
     
  (defun make-pattern (array designs)
    (make-instance 'pattern :array array :designs designs))
  
  (defun pattern-width (pattern)
    (nyi))
  
  (defun pattern-height (pattern)
    (nyi))
  
  (defun make-stencil (array)
    (nyi))
  
  (defclass rectangular-tile (design)
    ((width  :initarg :width      :reader rectangular-tile-width)
     (height :initarg :height     :reader rectangular-tile-height)
     (design :initarg :design     :reader rectangular-tile-design)))
  
  (defun make-rectangular-tile (design width height)
    (make-instance 'rectangular-tile
      :width width
      :height height
      :design design))
  