...

original commit: dbcbf0dc740ff6edb3f6067764d987d37665a021

collects/framework/color-model.ss

@@ -1,6 +1,8 @@
 (unit/sig framework:color-model^
   (import mzlib:function^)
 
+  ;(require-library "function.ss")
+
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;                                 ;;;
   ;;;           matrix ops            ;;;
@@ -130,36 +132,34 @@
   '(equal? (matrix-multiply '((1 2 3 4) (9 8 3 2)) '((0) (2) (0) (3)))
           '((16) (22)))
   
-  (void)
-  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;                                 ;;;
   ;;;           color model           ;;;
   ;;;                                 ;;;
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-  ; ntsc standard rgb phosphor constants:
+  ; ITU reccommendation phosphors:
   
   ;    red green blue
-  ;x   0.67 0.21 0.14
+  ;x   0.64 0.29 0.15
-  ;y   0.33 0.71 0.08
+  ;y   0.33 0.60 0.06
   ;
   ; white point: 
-  ; c : x-w = 0.31, y-w = 0.316, big-y-w = 100.0
+  ; c : x-w = 0.313, y-w = 0.329, big-y-w = 100.0
   
-  (define x-r 0.67)
+  (define x-r 0.64)
   (define y-r 0.33)
-  (define x-g 0.21)
+  (define x-g 0.29)
-  (define y-g 0.71)
+  (define y-g 0.60)
-  (define x-b 0.14)
+  (define x-b 0.15)
-  (define y-b 0.08)
+  (define y-b 0.06)
   
   (define z-r (- 1 x-r y-r))
   (define z-g (- 1 x-g y-g))
   (define z-b (- 1 x-b y-b))
-  
+ 
-  (define x-w 0.31)
+  (define x-w 0.313)
-  (define y-w 0.316)
+  (define y-w 0.329)
   (define big-y-w 100.0)
   
   (define-struct xyz (x y z))
@@ -192,34 +192,27 @@
                                          (,(xyz-z xyz-white))))])
       (apply values (car (transpose sigmas)))))
   
-  (define big-x-r (* x-r sigma-r))
+  '(printf "should be equal to xyz-white: ~n~a~n"
-  (define big-y-r (* y-r sigma-r))
+          (matrix-multiply pre-matrix `((,sigma-r)
-  (define big-z-r (* z-r sigma-r))
+                                        (,sigma-g)
-  
+                                        (,sigma-b))))
-  (define big-x-g (* x-g sigma-g))
-  (define big-y-g (* y-g sigma-g))
-  (define big-z-g (* z-g sigma-g))
-  
-  (define big-x-b (* x-b sigma-b))
-  (define big-y-b (* y-b sigma-b))
-  (define big-z-b (* z-b sigma-b))
   
   (define rgb->xyz-matrix
-    (map (lambda (row scalar)
+    (map (lambda (row)
-           (map (lambda (row-elt) (* row-elt scalar 1/255)) row))
+           (map (lambda (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
-         pre-matrix
+         pre-matrix))
-         `(,sigma-r ,sigma-g ,sigma-b)))
-  
-  ;(printf "rgb->xyz-matrix: ~n~s~n" rgb->xyz-matrix)
   
   (define xyz->rgb-matrix
     (matrix-invert rgb->xyz-matrix))
   
-  ;(printf "xyz->rgb-matrix: ~n~s~n" xyz->rgb-matrix)
+  '(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
   
   (define (rgb->xyz r g b)
     (apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
   
+  '(print-struct #t)
+  '(printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255))
+  
   (define (xyz->rgb x y z)
     (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))
 
@@ -230,6 +223,13 @@
   ;u-p = (4x)/(x+15y+3z)   v-p = (9y)/(x+15y+3z)
   ;u-p-n = (same but with -n) v-p-n = (same but with -n)
   
+  ; the following transformation is undefined if the y component
+  ; is zero.  So if it is, we bump it up a little.
+  
+  (define (xyz-tweak xyz)
+    (let* ([y (xyz-y xyz)])
+      (make-xyz (xyz-x xyz) (if (< y 0.01) 0.01 y) (xyz-z xyz))))
+  
   (define-struct luv (l u v))
   
   (define (xyz-denom xyz)
@@ -242,22 +242,31 @@
     (/ (* 9 (xyz-y xyz)) (xyz-denom xyz)))
   
   (define (xyz->luv xyz)
-    (let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white))
+    (let ([xyz (xyz-tweak xyz)])
-                              1/3))
+      (let* ([l (- (* 116 (expt (/ (xyz-y xyz) (xyz-y xyz-white))
-                 16)]
+                                1/3))
-           [u-p (xyz-u-p xyz)]
+                   16)]
-           [u-p-white (xyz-u-p xyz-white)]
+             [u-p (xyz-u-p xyz)]
-           [v-p (xyz-v-p xyz)]
+             [u-p-white (xyz-u-p xyz-white)]
-           [v-p-white (xyz-v-p xyz-white)])
+             [v-p (xyz-v-p xyz)]
-      (make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white)))))
+             [v-p-white (xyz-v-p xyz-white)])
+        (make-luv l (* 13 l (- u-p u-p-white)) (* 13 l (- v-p v-p-white))))))
   
   (define (luv-distance a b)
     (expt (+ (expt (- (luv-l a) (luv-l b)) 2)
              (expt (- (luv-u a) (luv-u b)) 2)
              (expt (- (luv-v a) (luv-v b)) 2))
-          1/3))
+          1/2))
   
   (define (rgb-color-distance r-a g-a b-a r-b g-b b-b)
     (let* ([luv-a (xyz->luv (rgb->xyz r-a g-a b-a))]
            [luv-b (xyz->luv (rgb->xyz r-b g-b b-b))])
-      (luv-distance luv-a luv-b))))
+      (luv-distance luv-a luv-b)))
+  
+  '(rgb-color-distance 0 0 0 0 0 0)
+ 
+  '(print-struct #t)
+  
+  '(xyz->luv (make-xyz 95.0 100.0 141.0))
+  '(xyz->luv (make-xyz 60.0 80.0 20.0))
+)