commit f76c2a31468591aaae2f3b246f4fd57dc267988a
parent 3219cfd0b6f600e3ee427f05a153b35b2ce7cd94
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 8 Jun 2010 13:18:15 -0600
macro-stepper: fixed colors for white-on-black display
original commit: 1c9bb4a72ad72e8e247240edde0f27974eb831db
Diffstat:
1 file changed, 109 insertions(+), 18 deletions(-)
diff --git 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
-
-(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))
+;; Color translation
+;; 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"|#))
