summaryrefslogtreecommitdiffstats
path: root/colorspc.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commit5145dd3aa0c02c9fc496d1432fc4410674206e1d (patch)
tree540afc30c51da085f5bd8ec3f4c89f6496e7900d /colorspc.scm
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.tar.gz
slib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.zip
Import Upstream version 3a2upstream/3a2
Diffstat (limited to 'colorspc.scm')
-rw-r--r--colorspc.scm43
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)))