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

adjust various plumbing to get the drracket icon to the startup screen. Only to realize

Browse Source 
that the startup screen is a dialog% and thus doesn't have set-icon

related to PR 12241
This commit is contained in:
Robby Findler 2011-09-29 13:43:18 -05:00
parent 56effc21f9
commit b95b346a4e
5 changed files with 70 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drracket/private/drracket-normal.rkt
View File

@ -7,6 +7,7 @@
framework/private/bday
framework/splash
racket/file
"frame-icon.rkt"
"eb.rkt")
(define files-to-open (command-line #:args filenames filenames))
@ -127,7 +128,8 @@
(start-splash normal-bitmap-spec
"DrRacket"
700
#:allow-funny? #t)
#:allow-funny? #t
#:frame-icon todays-icon)
(when (getenv "PLTDRBREAK")
(printf "PLTDRBREAK: creating break frame\n") (flush-output)

39
collects/drracket/private/frame-icon.rkt Normal file
View File

@ -0,0 +1,39 @@
#lang racket/base
(require racket/class racket/draw)
(provide todays-icon)
(define todays-icon
(and (eq? (system-type) 'unix)
(let ()
;; avoid building the mask unless we use it
(define todays-icon
(make-object bitmap%
(collection-file-path
(case (date-week-day (seconds->date (current-seconds)))
[(6 0) "plt-logo-red-shiny.png"]
[else "plt-logo-red-diffuse.png"])
"icons")
'png/mask))
(define todays-icon-bw-mask
(and (send todays-icon ok?)
(send todays-icon get-loaded-mask)
(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)))
(send todays-icon set-loaded-mask todays-icon-bw-mask)
todays-icon)))

36
collects/drracket/private/main.rkt
View File

@ -3,6 +3,7 @@
(require string-constants
mzlib/contract
"drsig.rkt"
"frame-icon.rkt"
mred
framework
mzlib/class
@ -33,40 +34,7 @@
name val predicate
#:aliases (list (string->symbol (regexp-replace #rx"^drracket:" (symbol->string name) "drscheme:")))))
(when (eq? (system-type) 'unix)
(let ()
;; avoid building the mask unless we use it
(define todays-icon
(make-object bitmap%
(collection-file-path
(case (date-week-day (seconds->date (current-seconds)))
[(6 0) "plt-logo-red-shiny.png"]
[else "plt-logo-red-diffuse.png"])
"icons")
'png/mask))
(define todays-icon-bw-mask
(and (send todays-icon ok?)
(send todays-icon get-loaded-mask)
(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)))
(send todays-icon set-loaded-mask todays-icon-bw-mask)
(frame:current-icon todays-icon)))
(frame:current-icon todays-icon)
(application-file-handler
(let ([default (application-file-handler)])

14
collects/framework/splash.rkt
View File

@ -138,7 +138,9 @@
(set! icons (cons (make-icon bm x y) icons))
(refresh-splash))
(define (start-splash splash-draw-spec _splash-title width-default #:allow-funny? [allow-funny? #f])
(define (start-splash splash-draw-spec _splash-title width-default
#:allow-funny? [allow-funny? #f]
#:frame-icon [frame-icon #f])
(unless allow-funny? (set! funny? #f))
(set! splash-title _splash-title)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
@ -152,6 +154,16 @@
(on-splash-eventspace/ret
(send (get-gauge) set-range splash-max-width)
(send splash-tlw set-label splash-title)
#; ;; commented out because dialogs don't accept set-icon
(when frame-icon
(if (pair? frame-icon)
(let ([small (car icon)]
[large (cdr icon)])
(send splash-tlw set-icon small (send small get-loaded-mask) 'small)
(send splash-tlw set-icon large (send large get-loaded-mask) 'large))
(send splash-tlw set-icon frame-icon (send icon get-loaded-mask) 'both)))
(cond
[(or (path? splash-draw-spec)
(string? splash-draw-spec))

16
collects/scribblings/framework/splash.scrbl
View File

@ -24,7 +24,14 @@ that number to control the gauge along the bottom of the splash screen.
exact-nonnegative-integer?))]
[splash-title string?]
[width-default exact-nonnegative-integer?]
[#:allow-funny? allow-funny? boolean? #f])
[#:allow-funny? allow-funny? boolean? #f]
[#:frame-icon
frame-icon
(or/c #f
(is-a?/c bitmap%)
(cons/c (is-a?/c bitmap%)
(is-a?/c bitmap%)))
#f])
void?]{
Starts a new splash screen. The splash screen is created in its own, new
@tech[#:doc '(lib "scribblings/gui/gui.scrbl") #:key "eventspace"]{eventspace}.
@ -51,8 +58,11 @@ that number to control the gauge along the bottom of the splash screen.
of the area to draw.
The @racket[allow-funny?] argument determines if a special gauge is used on Christmas day.
}
The @racket[frame-icon] is used just like the value of the parameter @racket[frame:current-icon] is used,
but for the splash screen.
}
@defproc[(shutdown-splash) void?]{
Stops the splash window's gauge from advancing. Call this after all of the files have been loaded.
}