Import Upstream version 3a2upstream/3a2

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)))