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))
(define dark-color (make-object color% 50 0 50))
(define dark-wob-color (make-object color% 220 150 220))
(define first-line-text-mixin
(mixin ((class->interface text%)) (first-line-text-mixin<%>)
@ -116,33 +117,46 @@
[line-left (+ (unbox bx) dx)]
[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)
(when (eq? (send dc get-smoothing) 'aligned)
(let ([start 3/10]
[end 0]
[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])
(unless (zero? i)
(send dc set-alpha (+ start (* (- end start) (/ i steps))))
(send dc draw-line
line-left
(+ line-height i)
line-right
(+ line-height i))
(loop (- i 1)))))))
(let ([alpha-value (+ start (* (- end start) (/ i steps)))])
(send dc set-alpha alpha-value)
(send dc draw-line
line-left
(+ line-height i)
line-right
(+ line-height i))
(loop (- i 1))))))))
(send dc set-alpha 1)
(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
(+ (unbox bx) dx)
(+ (unbox by) dy)
(unbox bw)
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 set-text-foreground old-text-foreground)

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

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