diff options
Diffstat (limited to 'colorspc.scm')
| -rw-r--r-- | colorspc.scm | 43 |
1 files changed, 27 insertions, 16 deletions
diff --git a/colorspc.scm b/colorspc.scm index 3a88767..814149b 100644 --- a/colorspc.scm +++ b/colorspc.scm @@ -345,13 +345,6 @@ (or (color:process-params parametric-factors) '(2 1 1))))))) (map sqrt (map * lch1 lch2)))) -;@ -(define (XYZ:normalize-colors lst) - (define sum (apply max (map (lambda (XYZ) (apply + XYZ)) lst))) - (map (lambda (XYZ) (map (lambda (x) (/ x sum)) XYZ)) lst)) -;@ -(define (XYZ:normalize XYZ) - (car (XYZ:normalize-colors (list XYZ)))) ;;; Chromaticity ;@ @@ -440,6 +433,29 @@ (vector-set! cie:y-bar idx (read iprt)) (vector-set! cie:z-bar idx (read iprt)))))))) ;@ +(define (read-cie-illuminant path) + (define siv (make-vector 107)) + (call-with-input-file path + (lambda (iprt) + (do ((idx 0 (+ 1 idx))) + ((>= idx 107) siv) + (vector-set! siv idx (read iprt)))))) +;@ +(define (read-normalized-illuminant path) + (define siv (read-cie-illuminant path)) + (let ((yw (/ (cadr (spectrum->XYZ siv 300e-9 830e-9))))) + (illuminant-map (lambda (w x) (* x yw)) siv))) +;@ +(define (illuminant-map proc siv) + (define prod (make-vector 107)) + (do ((idx 106 (+ -1 idx)) + (w 830e-9 (+ -5e-9 w))) + ((negative? idx) prod) + (vector-set! prod idx (proc w (vector-ref siv idx))))) +;@ +(define (illuminant-map->XYZ proc siv) + (spectrum->XYZ (illuminant-map proc siv) 300e-9 830e-9)) +;@ (define (wavelength->XYZ wl) (if (not cie:y-bar) (require 'ciexyz)) (set! wl (- (/ wl 5.e-9) 380/5)) @@ -453,8 +469,6 @@ (interpolate cie:y-bar wlf res) (interpolate cie:z-bar wlf res))) (slib:error 'wavelength->XYZ 'out-of-range wl))) -(define (wavelength->CIEXYZ wl) - (XYZ:normalize (wavelength->XYZ wl))) (define (wavelength->chromaticity wl) (XYZ->chromaticity (wavelength->XYZ wl))) ;@ @@ -509,8 +523,6 @@ (set! y (+ y (* (vector-ref cie:y-bar kdx) inten))) (set! z (+ z (* (vector-ref cie:z-bar kdx) inten)))))))) (else (slib:error 'spectrum->XYZ 'wna args)))) -(define (spectrum->CIEXYZ . args) - (XYZ:normalize (apply spectrum->XYZ args))) (define (spectrum->chromaticity . args) (XYZ->chromaticity (apply spectrum->XYZ args))) ;@ @@ -522,15 +534,14 @@ (pi*2*h*c*c (* 2 pi h*c c))) (lambda (temp . span) (define h*c/kT (/ h*c k temp)) - (define pi*2*h*c*c*span (* pi*2*h*c*c (if (null? span) 1.e-9 (car span)))) + (define pi*2*h*c*c*span + (* pi*2*h*c*c (if (null? span) 1.e-9 (car span)))) (lambda (x) (/ pi*2*h*c*c*span (expt x 5) (- (exp (/ h*c/kT x)) 1)))))) ;@ -(define (temperature->XYZ temp) - (spectrum->XYZ (blackbody-spectrum temp 5.e-9))) -(define (temperature->CIEXYZ temp) - (XYZ:normalize (temperature->XYZ temp))) +(define (temperature->XYZ temp . span) + (spectrum->XYZ (apply blackbody-spectrum temp span))) ;was .5e-9 (define (temperature->chromaticity temp) (XYZ->chromaticity (temperature->XYZ temp))) |