From adf7bea91b92d3410d96cee82135af4e17fc557d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 25 Oct 1999 23:10:49 +0000 Subject: [PATCH] ... original commit: a4cbca80e931933028234c6dbca0efb4bd267b1f --- collects/framework/color-model.ss | 263 ++++++++++++++++++++++++++++++ collects/framework/frameworks.ss | 4 + collects/framework/guiutils.ss | 24 ++- collects/framework/text.ss | 18 +- 4 files changed, 297 insertions(+), 12 deletions(-) create mode 100644 collects/framework/color-model.ss diff --git a/collects/framework/color-model.ss b/collects/framework/color-model.ss new file mode 100644 index 00000000..cee0243b --- /dev/null +++ b/collects/framework/color-model.ss @@ -0,0 +1,263 @@ +(unit/sig framework:color-model^ + (import mzlib:function^) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; ;;; + ;;; MATRIX OPS ;;; + ;;; ;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; Matrix inversion using Cramer's Rule + + ; submatrix : (list-of (list-of num)) int int -> (list-of (list-of num)) + ; submatrix "crosses out" row i and column j from the matrix, returning a new one + + (define (submatrix source i j) + (let row-loop ([row 0]) + (cond + [(eq? row (length source)) null] + [(eq? row i) (row-loop (+ row 1))] + [else + (cons + (let col-loop ([col 0]) + (cond + [(eq? col (length (car source))) null] + [(eq? col j) (col-loop (+ col 1))] + [else + (cons (list-ref (list-ref source row) col) + (col-loop (+ col 1)))])) + (row-loop (+ row 1)))]))) + + ;(equal? (submatrix test-matrix 1 2) + ; '((1 2 6) (7 8 4))) + + ; det : (list-of (list-of num)) -> num + + (define (det matrix) + (if (null? matrix) + 1 + (let loop ([row 0] [sign 1]) + (if (= row (length matrix)) + 0 + (+ (* sign + (list-ref (list-ref matrix row) 0) + (det (submatrix matrix row 0))) + (loop (+ row 1) (- sign))))))) + + ;(define square-test-matrix '((3 20 3) (37 0 8) (2 1 4))) + + ;(= (det square-test-matrix) -2553) + + ; invert : (list-of (list-of num)) -> (list-of (list-of num)) + + (define (matrix-invert matrix) + (let-values ([(width height) (matrix-dimension matrix)]) + (when (not (= width height)) + (error 'invert "matrix is not square: ~s" matrix)) + (let ([delta-inv (/ 1 (det matrix))]) + (let row-loop ([row 0] [sign 1]) + (if (= row (length matrix)) + null + (cons + (let col-loop ([col 0] [sign sign]) + (if (= col (length (car matrix))) + null + (cons (* delta-inv + sign + (det (submatrix matrix col row))) + (col-loop (+ col 1) (- sign))))) + (row-loop (+ row 1) (- sign)))))))) + + ;(equal? (matrix-invert square-test-matrix) + ; '((8/2553 77/2553 -160/2553) (44/851 -2/851 -29/851) (-1/69 -1/69 20/69))) + + ; matrix-dimension : (list-of (list-of num)) -> (values num num) + ; takes a matrix, returns width and height + + (define (matrix-dimension matrix) + (when (not (pair? matrix)) + (error 'matrix-dimension "matrix argument is not a list: ~s" matrix)) + (let ([height (length matrix)]) + (when (= height 0) + (error 'matrix-dimension "matrix argument is empty: ~s" matrix)) + (when (not (pair? (car matrix))) + (error 'matrix-dimension "matrix row is not a list: ~s" (car matrix))) + (let ([width (length (car matrix))]) + (when (= width 0) + (error 'matrix-dimension "matrix argument has width 0: ~s" matrix)) + (let loop ([rows matrix]) + (if (null? rows) + (values width height) + (begin + (when (not (pair? (car rows))) + (error 'matrix-dimension "row is not a list: ~s" (car rows))) + (when (not (= width (length (car rows)))) + (error 'matrix-dimension "rows have different widths: ~s and ~s" width (length (car rows)))) + (loop (cdr rows)))))))) + + ; transpose : (list-of (list-of num)) -> (list-of (list-of num)) + (define (transpose vector) (apply map list vector)) + + + ;; test code + '(equal? (transpose '((3 2 1) (9 8 7))) '((3 9) (2 8) (1 7))) + + ; inner-product : (list-of num) (list-of num) -> num + + (define (inner-product a b) + (foldl + 0 (map * a b))) + + ;; test code + '(= (inner-product '(4 1 3) '(0 3 4)) + 15) + + ; matrix-multiply: (list-of (list-of num)) (list-of (list-of num)) -> (list-of (list-of num)) + ; multiplies the two matrices. + + (define (matrix-multiply a b) + (let-values ([(width-a height-a) (matrix-dimension a)] + [(width-b height-b) (matrix-dimension b)]) + (when (not (= width-a height-b)) + (error 'matrix-multiply "matrix dimensions do not match for multiplication")) + (let ([b-t (transpose b)]) + (map (lambda (row) + (map (lambda (col) + (inner-product row col)) + b-t)) + a)))) + + ;; test code + '(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: + + ; red green blue + ;x 0.67 0.21 0.14 + ;y 0.33 0.71 0.08 + ; + ; white point: + ; C : x-w = 0.31, y-w = 0.316, big-y-w = 100.0 + + (define x-r 0.67) + (define y-r 0.33) + (define x-g 0.21) + (define y-g 0.71) + (define x-b 0.14) + (define y-b 0.08) + + (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 y-w 0.316) + (define big-y-w 100.0) + + (define-struct XYZ (X Y Z)) + + (define (xy-big-y->XYZ x y big-y) + (let ([sigma (/ big-y y)]) + (make-XYZ + (* x sigma) + (* y sigma) + (* (- 1 x y) sigma)))) + + (define XYZ-white (xy-big-y->XYZ x-w y-w big-y-w)) + + ;`((,(XYZ-X XYZ-white) ,x-r ,x-g ,x-b) + ; (,(XYZ-Y XYZ-white) ,y-r ,y-g ,y-b) + ; (,(XYZ-Z XYZ-white) ,z-r ,z-g ,z-b)) + + ; sigmas were calculated by soving a set of linear equations based upon NTSC standard phosphors + + (define pre-matrix `((,x-r ,x-g ,x-b) + (,y-r ,y-g ,y-b) + (,z-r ,z-g ,z-b))) + + (define-values (sigma-r sigma-g sigma-b) + (let* ([inversion + (matrix-invert pre-matrix)] + [sigmas + (matrix-multiply inversion `((,(XYZ-X XYZ-white)) + (,(XYZ-Y XYZ-white)) + (,(XYZ-Z XYZ-white))))]) + (apply values (car (transpose sigmas))))) + + (define big-x-r (* x-r sigma-r)) + (define big-y-r (* y-r sigma-r)) + (define big-z-r (* z-r sigma-r)) + + (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-elt) (* row-elt scalar 1/255)) row)) + 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) + + (define (rgb->xyz r g b) + (apply make-XYZ (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b)))))))) + + (define (xyz->rgb x y z) + (car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z))))))) + + ;L* = 116(Y/big-y-n)^1/3 - 16, Y/big-y-n > 0.01 + ;u* = 13 L*(u-p - u-p-n) + ;v* = 13 L*(v-p - v-p-n) + ; + ;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) + + (define-struct Luv (L u v)) + + (define (XYZ-denom XYZ) + (+ (XYZ-X XYZ) (* 15 (XYZ-Y XYZ)) (* 3 (XYZ-Z XYZ)))) + + (define (XYZ-u-p XYZ) + (/ (* 4 (XYZ-X XYZ)) (XYZ-denom XYZ))) + + (define (XYZ-v-p XYZ) + (/ (* 9 (XYZ-Y XYZ)) (XYZ-denom XYZ))) + + (define (XYZ->Luv XYZ) + (let* ([L (- (* 116 (expt (/ (XYZ-Y XYZ) (XYZ-Y XYZ-white)) + 1/3)) + 16)] + [u-p (XYZ-u-p XYZ)] + [u-p-white (XYZ-u-p XYZ-white)] + [v-p (XYZ-v-p XYZ)] + [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)) + + (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)))) \ No newline at end of file diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 67d92119..c53cfce9 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -258,9 +258,13 @@ (define-signature framework:main^ ()) +(define-signature framework:color-model^ + (rgb-color-distance)) + (define-signature frameworkc^ ([unit application : framework:application^] [unit version : framework:version^] + [unit color-model : framework:color-model^] [unit exn : framework:exn^] [unit exit : framework:exit^] [unit preferences : framework:preferences^] diff --git a/collects/framework/guiutils.ss b/collects/framework/guiutils.ss index 88d615e5..f1130d4c 100644 --- a/collects/framework/guiutils.ss +++ b/collects/framework/guiutils.ss @@ -119,17 +119,29 @@ [(message true-choice false-choice) (get-choice message true-choice false-choice "Warning")] [(message true-choice false-choice title) - (letrec ([result #f] + (get-choice message true-choice false-choice title 'disallow-close)] + [(message true-choice false-choice title default-result) + (letrec ([result default-result] [dialog (make-object (class dialog% () + (rename [super-on-close on-close] + [super-can-close? can-close?]) (override [can-close? (lambda () - (bell) - (message-box title - (format "Please choose either \"~a\" or \"~a\"" - true-choice false-choice)) - #f)]) + (cond + [(eq? default-result 'disallow-close) + (bell) + (message-box title + (format "Please choose either \"~a\" or \"~a\"" + true-choice false-choice)) + #f] + [else + (super-can-close?)]))] + [on-close + (lambda () + (set! result default-result) + (super-on-close))]) (sequence (super-init title))))] [on-true diff --git a/collects/framework/text.ss b/collects/framework/text.ss index b00c9a85..e7f54633 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -4,7 +4,8 @@ [editor : framework:editor^] [preferences : framework:preferences^] [keymap : framework:keymap^] - [gui-utils : framework:gui-utils^] + [gui-utils : framework:gui-utils^] + [color-model : framework:color-model^] [mzlib:function : mzlib:function^]) (rename [-keymap% keymap%]) @@ -220,11 +221,16 @@ [tmpc (make-object color% 0 0 0)]) (if rc (begin (send dc try-color rc tmpc) - (and (<= (max (abs (- (send rc red) (send tmpc red))) - (abs (- (send rc blue) (send tmpc blue))) - (abs (- (send rc green) (send tmpc green)))) - 50) - rc)) + (if (<= (color-model:rgb-color-distance + (send rc red) + (send rc green) + (send rc blue) + (send tmpc red) + (send tmpc green) + (send tmpc blue)) + 7) + rc + #f)) rc))] [first-number (lambda (x y) (if (number? x) x y))] [left (max left-margin (first-number (rectangle-left rectangle) view-x))]