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

improved the mask for the new icon

Browse Source 
svn: r17362
This commit is contained in:
Robby Findler 2009-12-20 04:58:55 +00:00
parent 9f8375c999
commit 3ee15b5295
1 changed files with 22 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/drscheme/private/unit.ss
View File

@ -56,6 +56,27 @@ module browser threading seems wrong.
[else "plt-logo-red-diffuse.png"])) [else "plt-logo-red-diffuse.png"]))
'png/mask)) 'png/mask))
(define todays-icon-bw-mask
(and (send todays-icon ok?)
(send todays-icon get-loaded-mask)
(eq? (system-type) 'unix) ;; avoid computing this unless we use it
(let* ([w (send todays-icon get-width)]
[h (send todays-icon get-height)]
[bm (make-object bitmap% w h #t)]
[color-mask (send todays-icon get-loaded-mask)]
[src-bytes (make-bytes (* w h 4) 0)]
[dest-bits (make-bytes (* w h 4) 255)]
[bdc (make-object bitmap-dc% bm)]
[black (send the-color-database find-color "black")]
[white (send the-color-database find-color "white")])
(send color-mask get-argb-pixels 0 0 w h src-bytes #t)
(for ([i (in-range 0 w)])
(for ([j (in-range 0 h)])
(let ([b (= (bytes-ref src-bytes (* 4 (+ i (* j h)))) 0)])
(send bdc set-pixel i j (if b white black)))))
(send bdc set-bitmap #f)
bm)))
(define-unit unit@ (define-unit unit@
(import [prefix help-desk: drscheme:help-desk^] (import [prefix help-desk: drscheme:help-desk^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]
@ -4111,7 +4132,7 @@ module browser threading seems wrong.
(inherit set-icon) (inherit set-icon)
(when (send todays-icon ok?) (when (send todays-icon ok?)
(case (system-type) (case (system-type)
[(unix) (set-icon todays-icon #f #;(send todays-icon get-loaded-mask))])) [(unix) (set-icon todays-icon todays-icon-bw-mask)]))
(send definitions-canvas focus))) (send definitions-canvas focus)))