suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some white-on-black fixes

Browse Source 
svn: r11447
This commit is contained in:
Robby Findler 2008-08-27 04:42:45 +00:00
parent 0f1ac966f6
commit 8c9e4bcfe0
2 changed files with 44 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/drscheme/private/first-line-text.ss
View File

@ -12,6 +12,7 @@
highlight-first-line)) highlight-first-line))
(define dark-color (make-object color% 50 0 50)) (define dark-color (make-object color% 50 0 50))
(define dark-wob-color (make-object color% 220 150 220))
(define first-line-text-mixin (define first-line-text-mixin
(mixin ((class->interface text%)) (first-line-text-mixin<%>) (mixin ((class->interface text%)) (first-line-text-mixin<%>)
@ -116,33 +117,46 @@
[line-left (+ (unbox bx) dx)] [line-left (+ (unbox bx) dx)]
[line-right (+ (unbox bx) dx (unbox bw))]) [line-right (+ (unbox bx) dx (unbox bw))])
(send dc set-pen "black" 1 'solid) (if (preferences:get 'framework:white-on-black?)
(send dc set-pen "white" 1 'solid)
(send dc set-pen "black" 1 'solid))
(send dc draw-line line-left line-height line-right line-height) (send dc draw-line line-left line-height line-right line-height)
(when (eq? (send dc get-smoothing) 'aligned) (when (eq? (send dc get-smoothing) 'aligned)
(let ([start 3/10] (let ([start 3/10]
[end 0] [end 0]
[steps 10]) [steps 10])
(send dc set-pen dark-color 1 'solid) (send dc set-pen
(if (preferences:get 'framework:white-on-black?)
dark-wob-color
dark-color)
1
'solid)
(let loop ([i steps]) (let loop ([i steps])
(unless (zero? i) (unless (zero? i)
(send dc set-alpha (+ start (* (- end start) (/ i steps)))) (let ([alpha-value (+ start (* (- end start) (/ i steps)))])
(send dc draw-line (send dc set-alpha alpha-value)
line-left (send dc draw-line
(+ line-height i) line-left
line-right (+ line-height i)
(+ line-height i)) line-right
(loop (- i 1))))))) (+ line-height i))
(loop (- i 1))))))))
(send dc set-alpha 1) (send dc set-alpha 1)
(send dc set-pen "gray" 1 'transparent) (send dc set-pen "gray" 1 'transparent)
(send dc set-brush "white" 'solid) (if (preferences:get 'framework:white-on-black?)
(send dc set-brush "black" 'solid)
(send dc set-brush "white" 'solid))
(send dc draw-rectangle (send dc draw-rectangle
(+ (unbox bx) dx) (+ (unbox bx) dx)
(+ (unbox by) dy) (+ (unbox by) dy)
(unbox bw) (unbox bw)
th) th)
(send dc set-text-foreground (send the-color-database find-color "black")) (send dc set-text-foreground
(if (preferences:get 'framework:white-on-black?)
(send the-color-database find-color "white")
(send the-color-database find-color "black")))
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy))) (send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy)))
(send dc set-text-foreground old-text-foreground) (send dc set-text-foreground old-text-foreground)

36
collects/lang/htdp-langs.ss
View File

@ -376,6 +376,7 @@
(inherit get-manual) (inherit get-manual)
(define/override (extra-repl-information settings port) (define/override (extra-repl-information settings port)
(define welcome (drscheme:rep:get-welcome-delta))
(define (go str sd) (define (go str sd)
(let* ([s (make-object string-snip% str)] (let* ([s (make-object string-snip% str)]
[sl (editor:get-standard-style-list)] [sl (editor:get-standard-style-list)]
@ -387,29 +388,29 @@
(define tps (htdp-lang-settings-teachpacks settings)) (define tps (htdp-lang-settings-teachpacks settings))
(unless (null? tps) (unless (null? tps)
(go "Teachpack" (drscheme:rep:get-welcome-delta)) (go "Teachpack" welcome)
(cond (cond
[(= 1 (length tps)) [(= 1 (length tps))
(go ": " (drscheme:rep:get-welcome-delta)) (go ": " welcome)
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))] (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))]
[(= 2 (length tps)) [(= 2 (length tps))
(go "s: " (drscheme:rep:get-welcome-delta)) (go "s: " welcome)
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta)) (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
(go " and " (drscheme:rep:get-welcome-delta)) (go " and " welcome)
(go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))] (go (cadr (cadr tps)) (drscheme:rep:get-dark-green-delta))]
[else [else
(go "s: " (drscheme:rep:get-welcome-delta)) (go "s: " welcome)
(go (cadr (car tps)) (drscheme:rep:get-dark-green-delta)) (go (cadr (car tps)) (drscheme:rep:get-dark-green-delta))
(let loop ([these-tps (cdr tps)]) (let loop ([these-tps (cdr tps)])
(cond (cond
[(null? (cdr these-tps)) [(null? (cdr these-tps))
(go ", and " (drscheme:rep:get-welcome-delta)) (go ", and " welcome)
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))] (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))]
[else [else
(go ", " (drscheme:rep:get-welcome-delta)) (go ", " welcome)
(go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta)) (go (cadr (car these-tps)) (drscheme:rep:get-dark-green-delta))
(loop (cdr these-tps))]))]) (loop (cdr these-tps))]))])
(go "." (drscheme:rep:get-welcome-delta)) (go "." welcome)
(newline port))) (newline port)))
(inherit get-module get-transformer-module get-init-code (inherit get-module get-transformer-module get-init-code
@ -1032,15 +1033,16 @@
(thread-cell-set! current-test-coverage-info ht) (thread-cell-set! current-test-coverage-info ht)
(let ([rep (drscheme:rep:current-rep)]) (let ([rep (drscheme:rep:current-rep)])
(when rep (when rep
(send rep set-test-coverage-info (let ([on-sd (make-object style-delta%)]
ht [off-sd (make-object style-delta%)])
(let ([s (make-object style-delta%)]) (cond
(send s set-delta-foreground "black") [(preferences:get 'framework:white-on-black?)
s) (send on-sd set-delta-foreground "white")
(let ([s (make-object style-delta%)]) (send off-sd set-delta-foreground "indianred")]
(send s set-delta-foreground "firebrick") [else
s) (send on-sd set-delta-foreground "black")
#f))))) (send off-sd set-delta-foreground "firebrick")])
(send rep set-test-coverage-info ht on-sd off-sd #f))))))
(let ([ht (thread-cell-ref current-test-coverage-info)]) (let ([ht (thread-cell-ref current-test-coverage-info)])
(when ht (when ht
(hash-set! ht key (mcons #f expr))))) (hash-set! ht key (mcons #f expr)))))