macro-stepper: fixed colors for white-on-black display

original commit: 1c9bb4a72ad72e8e247240edde0f27974eb831db

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)))))
+        (list->vector
-      (define overflow-style (color-style "darkgray"))
+         (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])
+;; translate-color : color-string -> color%
-  (let* ([sd (new style-delta%)])
+(define (translate-color color-string)
-    (unless em? (send sd set-delta-background (if translate-color? (translate-color raw-color) raw-color)))
+  (let ([c (make-object color% color-string)])
-    (when em? (send sd set-weight-on 'bold))
+    (if (preferences:get 'framework:white-on-black?)
-    (unless em? (send sd set-underlined-off #t)
+        (let-values ([(r* g* b*)
-      (send sd set-weight-off 'bold))
+                      (lightness-invert (send c red) (send c green) (send c blue))])
-    sd))
+          #|
+          (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)
+(define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)])
-  (let ([wob-version (highlight-style-delta wob-color #f #:translate-color? #f)]
+  (let ([wob-version (highlight-style-delta wob-color em? #:translate-color? #f)]
-        [bow-version (highlight-style-delta bow-color #f #: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-highlight-d
-(define select-sub-highlight-d select-highlight-d)  ;; can get rid of this definition(?).
+  (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"|#))