From f76c2a31468591aaae2f3b246f4fd57dc267988a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 8 Jun 2010 13:18:15 -0600 Subject: [PATCH] macro-stepper: fixed colors for white-on-black display original commit: 1c9bb4a72ad72e8e247240edde0f27974eb831db --- .../macro-debugger/syntax-browser/display.rkt | 125 +++++++++++++++--- 1 file changed, 108 insertions(+), 17 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt index 653234d..f3b640e 100644 --- a/collects/macro-debugger/syntax-browser/display.rkt +++ b/collects/macro-debugger/syntax-browser/display.rkt @@ -158,8 +158,11 @@ (send delta set-delta-foreground color) (send style-list find-or-create-style base-style delta))) (define color-styles - (list->vector (map color-style (map translate-color (send: config config<%> get-colors))))) - (define overflow-style (color-style "darkgray")) + (list->vector + (map color-style + (map translate-color + (send: config config<%> get-colors))))) + (define overflow-style (color-style (translate-color "darkgray"))) (define color-partition (send: controller mark-manager<%> get-primary-partition)) (define offset start-position) @@ -215,7 +218,7 @@ ;; Styles subterms eq to the selected syntax (define/private (apply-selection-styles selected-syntax) (for ([r (send: range range<%> get-ranges selected-syntax)]) - (restyle-range r select-highlight-d))) + (restyle-range r (select-highlight-d)))) ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) @@ -273,16 +276,23 @@ (make-object string-snip% "")) (super-instantiate ()))) -;; Styles +;; Color translation -(define (highlight-style-delta raw-color em? #:translate-color? [translate-color? #t]) - (let* ([sd (new style-delta%)]) - (unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-color))) - (when em? (send sd set-weight-on 'bold)) - (unless em? (send sd set-underlined-off #t) - (send sd set-weight-off 'bold)) - sd)) +;; translate-color : color-string -> color% +(define (translate-color color-string) + (let ([c (make-object color% color-string)]) + (if (preferences:get 'framework:white-on-black?) + (let-values ([(r* g* b*) + (lightness-invert (send c red) (send c green) (send c blue))]) + #| + (printf "translate: ~s -> ~s\n" + (list (send c red) (send c green) (send c blue)) + (list r* g* b*)) + |# + (make-object color% r* g* b*)) + c))) +#; (define (translate-color color) (let ([reversed-color (case (string->symbol (string-downcase color)) @@ -295,20 +305,101 @@ reversed-color color))) +;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) +(define (lightness-invert r g b) + (define (c x) + (/ (exact->inexact x) 255.0)) + (define (d x) + (inexact->exact (round (* x 255)))) + (let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))]) + (values (d r) (d g) (d b)))) + +(define (lightness-invert* R G B) + (let-values ([(Hp Sl L) (rgb->hsl* R G B)]) + (hsl*->rgb Hp Sl (- 1.0 L)))) + +(define (rgb->hsl* R G B) + (define M (max R G B)) + (define m (min R G B)) + (define C (- M m)) + (define Hp + (cond [(zero? C) + ;; Undefined, but use 0 + 0.0] + [(= M R) + (realmod* (/ (- G B) C) 6)] + [(= M G) + (+ (/ (- B R) C) 2)] + [(= M B) + (+ (/ (- R G) C) 4)])) + (define L (* 0.5 (+ M m))) + (define Sl + (cond [(zero? C) 0.0] + [(>= L 0.5) (/ C (* 2 L))] + [else (/ C (- 2 (* 2 L)))])) + + (values Hp Sl L)) + +(define (hsl*->rgb Hp Sl L) + (define C + (cond [(>= L 0.5) (* 2 L Sl)] + [else (* (- 2 (* 2 L)) Sl)])) + (define X (* C (- 1 (abs (- (realmod Hp 2) 1))))) + (define-values (R1 G1 B1) + (cond [(< Hp 1) (values C X 0)] + [(< Hp 2) (values X C 0)] + [(< Hp 3) (values 0 C X)] + [(< Hp 4) (values 0 X C)] + [(< Hp 5) (values X 0 C)] + [(< Hp 6) (values C 0 X)])) + (define m (- L (* 0.5 C))) + (values (+ R1 m) (+ G1 m) (+ B1 m))) + +;; realmod : real integer -> real +;; Adjusts a real number to [0, base] +(define (realmod x base) + (define xint (ceiling x)) + (define m (modulo xint base)) + (realmod* (- m (- xint x)) base)) + +;; realmod* : real real -> real +;; Adjusts a number in [-base, base] to [0,base] +;; Not a real mod, but faintly reminiscent. +(define (realmod* x base) + (if (negative? x) + (+ x base) + x)) + +;; Styles + +(define (highlight-style-delta raw-color em? + #:translate-color? [translate-color? #t]) + (let* ([sd (new style-delta%)]) + (unless em? + (send sd set-delta-background + (if translate-color? (translate-color raw-color) raw-color))) + (when em? (send sd set-weight-on 'bold)) + (unless em? + (send sd set-underlined-off #t) + (send sd set-weight-off 'bold)) + sd)) + (define underline-style-delta (let ([sd (new style-delta%)]) (send sd set-underlined-on #t) sd)) -(define (mk-2-constant-style wob-color bow-color) - (let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)] - [bow-version (highlight-style-delta bow-color #f #:translate-color? #f)]) +(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)]) + (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)] + [bow-version (highlight-style-delta bow-color em? #:translate-color? #f)]) (λ () (if (preferences:get 'framework:white-on-black?) wob-version bow-version)))) -(define select-highlight-d (mk-2-constant-style "yellow" "darkgoldenrod")) -(define select-sub-highlight-d select-highlight-d) ;; can get rid of this definition(?). +(define select-highlight-d + (mk-2-constant-style "yellow" #t "darkgoldenrod")) +(define select-sub-highlight-d + (mk-2-constant-style "yellow" #f "darkgoldenrod")) -(define unhighlight-d (mk-2-constant-style "black" "white")) +(define unhighlight-d (mk-2-constant-style "white" #f #|"black"|#))