diff options
Diffstat (limited to 'color.scm')
| -rw-r--r-- | color.scm | 674 |
1 files changed, 674 insertions, 0 deletions
diff --git a/color.scm b/color.scm new file mode 100644 index 0000000..7f80fe5 --- /dev/null +++ b/color.scm @@ -0,0 +1,674 @@ +;;; "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) + +(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 convolve with a spectrum of +;;interest. The result of those convolutions 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 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 and 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 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 + (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) + (case space + ((CIEXYZ) (CIEXYZ->color args)) + ((RGB709) (RGB709->color args)) + ((L*a*b*) (L*a*b*->color args)) + ((L*u*v*) (L*u*v*->color args)) + ((L*C*h) (L*C*h->color args)) + ((sRGB) (sRGB->color args)) + ((xRGB) (apply xRGB->color args)) + ((e-sRGB) (e-sRGB->color args)) + (else (slib:error 'make-color ': 'not 'space? space)))) +;@ +(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:%.4f/%.4f/%.4f" + (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:%.4f/%.4f/%.4f" + (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:%.4f/%.4f/%.4f" + (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? 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*C*h:DE*94 + (color->L*C*h color1) + (color->L*C*h 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) |