;;; "color.scm" color data-type
;Copyright 2001, 2002 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'record)
(require 'color-space)
(require 'scanf)
(require 'printf)
(require 'string-case)
(require 'multiarg-apply)
(define color:rtd
(make-record-type "color"
'(encoding ;symbol
coordinates ;list of coordinates
parameter ;white-point or precision
)))
(define color:construct
(record-constructor color:rtd '(encoding coordinates parameter)))
(define color:encoding (record-accessor color:rtd 'encoding))
(define color:coordinates (record-accessor color:rtd 'coordinates))
(define color:parameter (record-accessor color:rtd 'parameter))
(define color:precision color:parameter)
(define color:color? (record-predicate color:rtd))
(define (color:white-point color)
(case (color:encoding color)
((CIEXYZ
RGB709
sRGB
xRGB
e-sRGB) CIEXYZ:D65)
((L*a*b*
L*u*v*
L*C*h)
(or (color:parameter color) CIEXYZ:D65))))
;;@subsubheading Measurement-based Color Spaces
(define (color:helper num-of-nums name list->color)
(lambda args
(define cnt 0)
(for-each (lambda (x)
(if (and (< cnt num-of-nums) (not (real? x)))
(slib:error name ': 'wrong-type x))
(set! cnt (+ 1 cnt)))
args)
(or (list->color args)
(slib:error name ': 'out-of-range args))))
;;@noindent
;;@cindex tristimulus
;;The @dfn{tristimulus} color spaces are those whose component values
;;are proportional measurements of light intensity. The CIEXYZ(1931)
;;system provides 3 sets of spectra to dot-product with a spectrum of
;;interest. The result of those dot-products is coordinates in CIEXYZ
;;space. All tristimuls color spaces are related to CIEXYZ by linear
;;transforms, namely matrix multiplication. Of the color spaces listed
;;here, CIEXYZ and RGB709 are tristimulus spaces.
;;@deftp {Color Space} CIEXYZ
;;The CIEXYZ color space covers the full @dfn{gamut}.
;;It is the basis for color-space conversions.
;;
;;CIEXYZ is a list of three inexact numbers between 0.0 and 1.1.
;;'(0. 0. 0.) is black; '(1. 1. 1.) is white.
;;@end deftp
;;@body
;;@1 must be a list of 3 numbers. If @1 is valid CIEXYZ coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (CIEXYZ->color XYZ)
(and (eqv? 3 (length XYZ))
(apply (lambda (x y z)
(and (real? x) (<= -0.001 x)
(real? y) (<= -0.001 y 1.001)
(real? z) (<= -0.001 z)
(color:construct 'CIEXYZ XYZ #f)))
XYZ)))
;;@args x y z
;;Returns the CIEXYZ color composed of @1, @2, @3. If the
;;coordinates do not encode a valid CIEXYZ color, then an error is
;;signaled.
(define color:CIEXYZ (color:helper 3 'color:CIEXYZ CIEXYZ->color))
;;@body Returns the list of 3 numbers encoding @1 in CIEXYZ.
(define (color->CIEXYZ color)
(if (not (color:color? color))
(slib:error 'color->CIEXYZ ': 'not 'color? color))
(case (color:encoding color)
((CIEXYZ) (append (color:coordinates color) '()))
((RGB709) (RGB709->CIEXYZ (color:coordinates color)))
((L*a*b*) (L*a*b*->CIEXYZ (color:coordinates color)
(color:white-point color)))
((L*u*v*) (L*u*v*->CIEXYZ (color:coordinates color)
(color:white-point color)))
((sRGB) (sRGB->CIEXYZ (color:coordinates color)))
((e-sRGB) (e-sRGB->CIEXYZ (color:precision color)
(color:coordinates color)))
((L*C*h) (L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color))
(color:white-point color)))
(else (slib:error 'color->CIEXYZ ': (color:encoding color) color))))
;;@deftp {Color Space} RGB709
;;BT.709-4 (03/00) @cite{Parameter values for the HDTV standards for
;;production and international programme exchange} specifies parameter
;;values for chromaticity, sampling, signal format, frame rates, etc., of
;;high definition television signals.
;;
;;An RGB709 color is represented by a list of three inexact numbers
;;between 0.0 and 1.0. '(0. 0. 0.) is black '(1. 1. 1.) is white.
;;@end deftp
;;@body
;;@1 must be a list of 3 numbers. If @1 is valid RGB709 coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (RGB709->color RGB)
(and (eqv? 3 (length RGB))
(apply (lambda (r g b)
(and (real? r) (<= -0.001 r 1.001)
(real? g) (<= -0.001 g 1.001)
(real? b) (<= -0.001 b 1.001)
(color:construct 'RGB709 RGB #f)))
RGB)))
;;@args r g b
;;Returns the RGB709 color composed of @1, @2, @3. If the
;;coordinates do not encode a valid RGB709 color, then an error is
;;signaled.
(define color:RGB709 (color:helper 3 'color:RGB709 RGB709->color))
;;@body Returns the list of 3 numbers encoding @1 in RGB709.
(define (color->RGB709 color)
(if (not (color:color? color))
(slib:error 'color->RGB709 ': 'not 'color? color))
(case (color:encoding color)
((RGB709) (append (color:coordinates color) '()))
((CIEXYZ) (CIEXYZ->RGB709 (color:coordinates color)))
(else (CIEXYZ->RGB709 (color->CIEXYZ color)))))
;;@subsubheading Perceptual Uniformity
;;@noindent
;;Although properly encoding the chromaticity, tristimulus spaces do not
;;match the logarithmic response of human visual systems to intensity.
;;Minimum detectable differences between colors correspond to a smaller
;;range of distances (6:1) in the L*a*b* and L*u*v* spaces than in
;;tristimulus spaces (80:1). For this reason, color distances are
;;computed in L*a*b* (or L*C*h).
;;@deftp {Color Space} L*a*b*
;;Is a CIE color space which better matches the human visual system's
;;perception of color. It is a list of three numbers:
;;@itemize @bullet
;;@item
;;0 <= L* <= 100 (CIE @dfn{Lightness})
;;@item
;;-500 <= a* <= 500
;;@item
;;-200 <= b* <= 200
;;@end itemize
;;@end deftp
;;@args L*a*b* white-point
;;@1 must be a list of 3 numbers. If @1 is valid L*a*b* coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (L*a*b*->color L*a*b* . white-point)
(and (list? L*a*b*)
(eqv? 3 (length L*a*b*))
(<= 0 (length white-point) 1)
(apply (lambda (L* a* b*)
(and (real? L*) (<= 0 L* 100)
(real? a*) (<= -500 a* 500)
(real? b*) (<= -200 b* 200)
(color:construct
'L*a*b* L*a*b*
(if (null? white-point) #f
(color->CIEXYZ (car white-point))))))
L*a*b*)))
;;@args L* a* b* white-point
;;Returns the L*a*b* color composed of @1, @2, @3 with @4.
;;@args L* a* b*
;;Returns the L*a*b* color composed of @1, @2, @3. If the coordinates
;;do not encode a valid L*a*b* color, then an error is signaled.
(define color:L*a*b* (color:helper 3 'color:L*a*b* L*a*b*->color))
;;@args color white-point
;;Returns the list of 3 numbers encoding @1 in L*a*b* with @2.
;;@args color
;;Returns the list of 3 numbers encoding @1 in L*a*b*.
(define (color->L*a*b* color . white-point)
(define (wp) (if (null? white-point)
CIEXYZ:D65
(color:coordinates (car white-point))))
(if (not (color:color? color))
(slib:error 'color->L*a*b* ': 'not 'color? color))
(case (color:encoding color)
((L*a*b*) (if (equal? (wp) (color:white-point color))
(append (color:coordinates color) '())
(CIEXYZ->L*a*b* (L*a*b*->CIEXYZ (color:coordinates color)
(color:white-point color))
(wp))))
((L*u*v*) (CIEXYZ->L*a*b* (L*u*v*->CIEXYZ (color:coordinates color)
(color:white-point color))
(wp)))
((L*C*h) (if (equal? (wp) (color:white-point color))
(L*C*h->L*a*b* (color:coordinates color))
(CIEXYZ->L*a*b* (L*a*b*->CIEXYZ
(L*C*h->L*a*b* (color:coordinates color))
(color:white-point color))
(wp))))
((CIEXYZ) (CIEXYZ->L*a*b* (color:coordinates color) (wp)))
(else (CIEXYZ->L*a*b* (color->CIEXYZ color) (wp)))))
;;@deftp {Color Space} L*u*v*
;;Is another CIE encoding designed to better match the human visual
;;system's perception of color.
;;@end deftp
;;@args L*u*v* white-point
;;@1 must be a list of 3 numbers. If @1 is valid L*u*v* coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (L*u*v*->color L*u*v* . white-point)
(and (list? L*u*v*)
(eqv? 3 (length L*u*v*))
(<= 0 (length white-point) 1)
(apply (lambda (L* u* v*)
(and (real? L*) (<= 0 L* 100)
(real? u*) (<= -500 u* 500)
(real? v*) (<= -200 v* 200)
(color:construct
'L*u*v* L*u*v*
(if (null? white-point) #f
(color->CIEXYZ (car white-point))))))
L*u*v*)))
;;@args L* u* v* white-point
;;Returns the L*u*v* color composed of @1, @2, @3 with @4.
;;@args L* u* v*
;;Returns the L*u*v* color composed of @1, @2, @3. If the coordinates
;;do not encode a valid L*u*v* color, then an error is signaled.
(define color:L*u*v* (color:helper 3 'color:L*u*v* L*u*v*->color))
;;@args color white-point
;;Returns the list of 3 numbers encoding @1 in L*u*v* with @2.
;;@args color
;;Returns the list of 3 numbers encoding @1 in L*u*v*.
(define (color->L*u*v* color . white-point)
(define (wp) (if (null? white-point)
(color:white-point color)
(car white-point)))
(if (not (color:color? color))
(slib:error 'color->L*u*v* ': 'not 'color? color))
(case (color:encoding color)
((L*u*v*) (append (color:coordinates color) '()))
((L*a*b*) (CIEXYZ->L*u*v* (L*a*b*->CIEXYZ (color:coordinates color)
(color:white-point color))
(wp)))
((L*C*h) (CIEXYZ->L*u*v*
(L*a*b*->CIEXYZ (L*C*h->L*a*b* (color:coordinates color))
(color:white-point color))
(wp)))
((CIEXYZ) (CIEXYZ->L*u*v* (color:coordinates color) (wp)))
(else (CIEXYZ->L*u*v* (color->CIEXYZ color) (wp)))))
;;@subsubheading Cylindrical Coordinates
;;@noindent
;;HSL (Hue Saturation Lightness), HSV (Hue Saturation Value), HSI (Hue
;;Saturation Intensity) and HCI (Hue Chroma Intensity) are cylindrical
;;color spaces (with angle hue). But these spaces are all defined in
;;terms device-dependent RGB spaces.
;;@noindent
;;One might wonder if there is some fundamental reason why intuitive
;;specification of color must be device-dependent. But take heart! A
;;cylindrical system can be based on L*a*b* and is used for predicting how
;;close colors seem to observers.
;;@deftp {Color Space} L*C*h
;;Expresses the *a and b* of L*a*b* in polar coordinates. It is a list of
;;three numbers:
;;@itemize @bullet
;;@item
;;0 <= L* <= 100 (CIE @dfn{Lightness})
;;@item
;;C* (CIE @dfn{Chroma}) is the distance from the neutral (gray) axis.
;;@item
;;0 <= h <= 360 (CIE @dfn{Hue}) is the angle.
;;@end itemize
;;
;;The colors by quadrant of h are:
;;@multitable @columnfractions .20 .60 .20
;;@item 0 @tab red, orange, yellow @tab 90
;;@item 90 @tab yellow, yellow-green, green @tab 180
;;@item 180 @tab green, cyan (blue-green), blue @tab 270
;;@item 270 @tab blue, purple, magenta @tab 360
;;@end multitable
;;@end deftp
;;@args L*C*h white-point
;;@1 must be a list of 3 numbers. If @1 is valid L*C*h coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (L*C*h->color L*C*h . white-point)
(and (list? L*C*h)
(eqv? 3 (length L*C*h))
(<= 0 (length white-point) 1)
(apply (lambda (L* C* h)
(and (real? L*) (<= 0 L* 100)
(real? C*) (<= 0 C*)
(real? h) (<= 0 h 360)
(color:construct
'L*C*h L*C*h
(if (null? white-point) #f
(color->CIEXYZ (car white-point))))))
L*C*h)))
;;@args L* C* h white-point
;;Returns the L*C*h color composed of @1, @2, @3 with @4.
;;@args L* C* h
;;Returns the L*C*h color composed of @1, @2, @3. If the coordinates
;;do not encode a valid L*C*h color, then an error is signaled.
(define color:L*C*h (color:helper 3 'color:L*C*h L*C*h->color))
;;@args color white-point
;;Returns the list of 3 numbers encoding @1 in L*C*h with @2.
;;@args color
;;Returns the list of 3 numbers encoding @1 in L*C*h.
(define (color->L*C*h color . white-point)
(if (not (color:color? color))
(slib:error 'color->L*C*h ': 'not 'color? color))
(if (and (eqv? 'L*C*h (color:encoding color))
(equal? (color:white-point color)
(if (null? white-point)
CIEXYZ:D65
(color:coordinates (car white-point)))))
(append (color:coordinates color) '())
(L*a*b*->L*C*h (apply color->L*a*b* color white-point))))
;;@subsubheading Digital Color Spaces
;;@noindent
;;The color spaces discussed so far are impractical for image data because
;;of numerical precision and computational requirements. In 1998 the IEC
;;adopted @cite{A Standard Default Color Space for the Internet - sRGB}
;;(@url{http://www.w3.org/Graphics/Color/sRGB}). sRGB was cleverly
;;designed to employ the 24-bit (256x256x256) color encoding already in
;;widespread use; and the 2.2 gamma intrinsic to CRT monitors.
;;@noindent
;;Conversion from CIEXYZ to digital (sRGB) color spaces is accomplished by
;;conversion first to a RGB709 tristimulus space with D65 white-point;
;;then each coordinate is individually subjected to the same non-linear
;;mapping. Inverse operations in the reverse order create the inverse
;;transform.
;;@deftp {Color Space} sRGB
;;Is "A Standard Default Color Space for the Internet". Most display
;;monitors will work fairly well with sRGB directly. Systems using ICC
;;profiles
;;@ftindex ICC Profile
;;@footnote{
;;@noindent
;;A comprehensive encoding of transforms between CIEXYZ and device color
;;spaces is the International Color Consortium profile format,
;;ICC.1:1998-09:
;;@quotation
;;The intent of this format is to provide a cross-platform device profile
;;format. Such device profiles can be used to translate color data
;;created on one device into another device's native color space.
;;@end quotation
;;}
;;should work very well with sRGB.
;;An sRGB color is a triplet of integers ranging 0 to 255. D65 is the
;;white-point for sRGB.
;;@end deftp
;;@body
;;@1 must be a list of 3 numbers. If @1 is valid sRGB coordinates,
;;then @0 returns the color specified by @1; otherwise returns #f.
(define (sRGB->color RGB)
(and (eqv? 3 (length RGB))
(apply (lambda (r g b)
(and (integer? r) (<= 0 r 255)
(integer? g) (<= 0 g 255)
(integer? b) (<= 0 b 255)
(color:construct 'sRGB RGB #f)))
RGB)))
;;@args r g b
;;Returns the sRGB color composed of @1, @2, @3. If the
;;coordinates do not encode a valid sRGB color, then an error is
;;signaled.
(define color:sRGB (color:helper 3 'color:sRGB sRGB->color))
;;@deftp {Color Space} xRGB
;;Represents the equivalent sRGB color with a single 24-bit integer. The
;;most significant 8 bits encode red, the middle 8 bits blue, and the
;;least significant 8 bits green.
;;@end deftp
;;@body
;;Returns the list of 3 integers encoding @1 in sRGB.
(define (color->sRGB color)
(if (not (color:color? color))
(slib:error 'color->sRGB ': 'not 'color? color))
(case (color:encoding color)
((CIEXYZ) (CIEXYZ->sRGB (color:coordinates color)))
((sRGB) (append (color:coordinates color) '()))
(else (CIEXYZ->sRGB (color->CIEXYZ color)))))
;;@body Returns the 24-bit integer encoding @1 in sRGB.
(define (color->xRGB color) (sRGB->xRGB (color->sRGB color)))
;;@args k
;;Returns the sRGB color composed of the 24-bit integer @1.
(define (xRGB->color xRGB)
(and (integer? xRGB) (<= 0 xRGB #xffffff)
(sRGB->color (xRGB->sRGB xRGB))))
;;@deftp {Color Space} e-sRGB
;;Is "Photography - Electronic still picture imaging - Extended sRGB color
;;encoding" (PIMA 7667:2001). It extends the gamut of sRGB; and its
;;higher precision numbers provide a larger dynamic range.
;;
;;A triplet of integers represent e-sRGB colors. Three precisions are
;;supported:
;;@table @r
;;@item e-sRGB10
;;0 to 1023
;;@item e-sRGB12
;;0 to 4095
;;@item e-sRGB16
;;0 to 65535
;;@end table
;;@end deftp
(define (esRGB->color prec-RGB)
(and (eqv? 4 (length prec-RGB))
(let ((range (and (pair? prec-RGB)
(case (car prec-RGB)
((10) 1023)
((12) 4095)
((16) 65535)
(else #f)))))
(apply (lambda (precision r g b)
(and (integer? r) (<= 0 r range)
(integer? g) (<= 0 g range)
(integer? b) (<= 0 b range)
(color:construct 'e-sRGB (cdr prec-RGB) precision)))
prec-RGB))))
;;@body @1 must be the integer 10, 12, or 16. @2 must be a list of 3
;;numbers. If @2 is valid e-sRGB coordinates, then @0 returns the color
;;specified by @2; otherwise returns #f.
(define (e-sRGB->color precision RGB)
(esRGB->color (cons precision RGB)))
;;@args 10 r g b
;;Returns the e-sRGB10 color composed of integers @2, @3, @4.
;;@args 12 r g b
;;Returns the e-sRGB12 color composed of integers @2, @3, @4.
;;@args 16 r g b
;;Returns the e-sRGB16 color composed of integers @2, @3, @4.
;;If the coordinates do not encode a valid e-sRGB color, then an error
;;is signaled.
(define color:e-sRGB (color:helper 4 'color:e-sRGB esRGB->color))
;;@body @1 must be the integer 10, 12, or 16. @0 returns the list of 3
;;integers encoding @2 in sRGB10, sRGB12, or sRGB16.
(define (color->e-sRGB precision color)
(case precision
((10 12 16)
(if (not (color:color? color))
(slib:error 'color->e-sRGB ': 'not 'color? color)))
(else (slib:error 'color->e-sRGB ': 'invalid 'precision precision)))
(case (color:encoding color)
((e-sRGB) (e-sRGB->e-sRGB (color:precision color)
(color:coordinates color)
precision))
((sRGB) (sRGB->e-sRGB precision (color:coordinates color)))
(else (CIEXYZ->e-sRGB precision (color->CIEXYZ color)))))
;;;; Polytypic Colors
;;; The rest of documentation is in "slib.texi"
;@
(define D65 (CIEXYZ->color CIEXYZ:D65))
(define D50 (CIEXYZ->color CIEXYZ:D50))
;@
(define (color? obj . typ)
(cond ((not (color:color? obj)) #f)
((null? typ) #t)
(else (eqv? (car typ) (color:encoding obj)))))
;@
(define (make-color space . args)
(apply (case space
((CIEXYZ) CIEXYZ->color)
((RGB709) RGB709->color)
((L*a*b*) L*a*b*->color)
((L*u*v*) L*u*v*->color)
((L*C*h) L*C*h->color)
((sRGB) sRGB->color)
((xRGB) xRGB->color)
((e-sRGB) e-sRGB->color)
(else (slib:error 'make-color ': 'not 'space? space)))
args))
;@
(define color-space color:encoding)
;@
(define (color-precision color)
(if (not (color:color? color))
(slib:error 'color-precision ': 'not 'color? color))
(case (color:encoding color)
((e-sRGB) (color:precision color))
((sRGB) 8)
(else #f)))
;@
(define (color-white-point color)
(if (not (color:color? color))
(slib:error 'color-white-point ': 'not 'color? color))
(case (color:encoding color)
((L*a*b*) (color:CIEXYZ (color:white-point color)))
((L*u*v*) (color:CIEXYZ (color:white-point color)))
((L*C*h) (color:CIEXYZ (color:white-point color)))
((RGB709) D65)
((sRGB) D65)
((e-sRGB) D65)
(else #f)))
;@
(define (convert-color color encoding . opt-arg)
(define (noarg)
(if (not (null? opt-arg))
(slib:error 'convert-color ': 'too-many 'arguments opt-arg)))
(if (not (color:color? color))
(slib:error 'convert-color ': 'not 'color? color))
(case encoding
((CIEXYZ) (noarg) (CIEXYZ->color (color->CIEXYZ color)))
((RGB709) (noarg) (RGB709->color (color->RGB709 color)))
((sRGB) (noarg) (sRGB->color (color->sRGB color)))
((e-sRGB) (e-sRGB->color (car opt-arg) (color->e-sRGB (car opt-arg) color)))
((L*a*b*) (apply L*a*b*->color (color->L*a*b* color) opt-arg))
((L*u*v*) (apply L*u*v*->color (color->L*u*v* color) opt-arg))
((L*C*h) (apply L*C*h->color (color->L*C*h color) opt-arg))
(else (slib:error 'convert-color ': encoding '?))))
;;; External color representations
;@
(define (color->string color)
(if (not (color:color? color))
(slib:error 'color->string ': 'not 'color? color))
(case (color:encoding color)
((CIEXYZ) (apply sprintf #f "CIEXYZ:%g/%g/%g"
(color:coordinates color)))
((L*a*b*) (apply sprintf #f "CIELab:%.2f/%.2f/%.2f"
(if (equal? CIEXYZ:D65 (color:white-point color))
(color:coordinates color)
(CIEXYZ->L*a*b* (L*a*b*->CIEXYZ
(color:coordinates color)
(color:white-point color))))))
((L*u*v*) (apply sprintf #f "CIELuv:%.2f/%.2f/%.2f"
(if (equal? CIEXYZ:D65 (color:white-point color))
(color:coordinates color)
(CIEXYZ->L*u*v* (L*u*v*->CIEXYZ
(color:coordinates color)
(color:white-point color))))))
((L*C*h) (apply sprintf #f "CIELCh:%.2f/%.2f/%.2f"
(if (equal? CIEXYZ:D65 (color:white-point color))
(color:coordinates color)
(L*a*b*->L*C*h
(CIEXYZ->L*a*b* (L*a*b*->CIEXYZ
(L*C*h->L*a*b*
(color:coordinates color))
(color:white-point color)))))))
((RGB709) (apply sprintf #f "RGBi:%g/%g/%g" (color:coordinates color)))
((sRGB) (apply sprintf #f "sRGB:%d/%d/%d" (color:coordinates color)))
((e-sRGB) (apply sprintf #f "e-sRGB%d:%d/%d/%d"
(color:precision color) (color:coordinates color)))
(else (slib:error 'color->string ': (color:encoding color) color))))
;@
(define (string->color str)
(define prec #f) (define coding #f)
(define x #f) (define y #f) (define z #f)
(cond ((eqv? 4 (sscanf str " %[CIEXYZciexyzLABUVlabuvHhRrGg709]:%f/%f/%f"
coding x y z))
(case (string-ci->symbol coding)
((CIEXYZ) (color:CIEXYZ x y z))
((CIELab) (color:L*a*b* x y z))
((CIELuv) (color:L*u*v* x y z))
((CIELCh) (color:L*C*h x y z))
((RGBi ; Xlib - C Language X Interface
RGB709) (color:RGB709 x y z))
(else #f)))
((eqv? 4 (sscanf str " %[sRGBSrgb]:%d/%d/%d" coding x y z))
(case (string-ci->symbol coding)
((sRGB) (color:sRGB x y z))
(else #f)))
((eqv? 5 (sscanf str " %[-esRGBESrgb]%d:%d/%d/%d" coding prec x y z))
(case (string-ci->symbol coding)
((e-sRGB) (color:e-sRGB prec x y z))
(else #f)))
((eqv? 2 (sscanf str " %[sRGBxXXRGB]:%6x%[/0-9a-fA-F]" coding x y))
(case (string-ci->symbol coding)
((sRGB
xRGB
sRGBx) (xRGB->color x))
(else #f)))
((and (eqv? 1 (sscanf str " #%6[0-9a-fA-F]%[0-9a-fA-F]" x y))
(eqv? 6 (string-length x)))
(xRGB->color (string->number x 16)))
((and (eqv? 2 (sscanf str " %[#0xX]%6[0-9a-fA-F]%[0-9a-fA-F]"
coding x y))
(eqv? 6 (string-length x))
(member coding '("#" "#x" "0x" "#X" "0X")))
(xRGB->color (string->number x 16)))
(else #f)))
;;;; visual color metrics
;@
(define (CIE:DE* color1 color2 . white-point)
(L*a*b*:DE* (apply color->L*a*b* color1 white-point)
(apply color->L*a*b* color2 white-point)))
;@
(define (CIE:DE*94 color1 color2 . parametric-factors)
(apply L*a*b*:DE*94
(color->L*a*b* color1)
(color->L*a*b* color2)
parametric-factors))
;@
(define (CMC:DE* color1 color2 . parametric-factors)
(apply CMC-DE
(color->L*C*h color1)
(color->L*C*h color2)
parametric-factors))
;;; Short names
;; (define CIEXYZ color:CIEXYZ)
;; (define RGB709 color:RGB709)
;; (define L*a*b* color:L*a*b*)
;; (define L*u*v* color:L*u*v*)
;; (define L*C*h color:L*C*h)
;; (define sRGB color:sRGB)
;; (define xRGB xRGB->color)
;; (define e-sRGB color:e-sRGB)