improved the icon a little bit more (making it appear on more windows)

svn: r17380
This commit is contained in:
Robby Findler 2009-12-21 18:28:24 +00:00
parent b4060f7157
commit 3272274f53
6 changed files with 78 additions and 37 deletions

View File

@ -25,6 +25,42 @@
[prefix drscheme:help-desk: drscheme:help-desk^])
(export)
(when (eq? (system-type) 'unix)
(let ()
;; avoid building the mask unless we use it
(define todays-icon
(make-object bitmap%
(build-path (collection-path "icons")
(case (date-week-day (seconds->date (current-seconds)))
[(6 0) "plt-logo-red-shiny.png"]
[else "plt-logo-red-diffuse.png"]))
'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)))
(application-file-handler
(let ([default (application-file-handler)])
(λ (name)

View File

@ -48,35 +48,6 @@ module browser threading seems wrong.
(define show-planet-paths (string-constant module-browser-show-planet-paths/short))
(define refresh (string-constant module-browser-refresh))
(define todays-icon
(make-object bitmap%
(build-path (collection-path "icons")
(case (date-week-day (seconds->date (current-seconds)))
[(6 0) "plt-logo-red-shiny.png"]
[else "plt-logo-red-diffuse.png"]))
'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@
(import [prefix help-desk: drscheme:help-desk^]
[prefix drscheme:app: drscheme:app^]
@ -4128,12 +4099,6 @@ module browser threading seems wrong.
(set-label-prefix (string-constant drscheme))
(set! newest-frame this)
(inherit set-icon)
(when (send todays-icon ok?)
(case (system-type)
[(unix) (set-icon todays-icon todays-icon-bw-mask)]))
(send definitions-canvas focus)))
(define execute-warning-canvas%

View File

@ -645,6 +645,28 @@
(frame)
@{Removes empty menus in a frame.})
(parameter-doc
frame:current-icon
(parameter/c (or/c #f
(is-a?/c bitmap%)
(cons/c (is-a?/c bitmap%)
(is-a?/c bitmap%))))
icon-spec
@{The value of this parameter is used by the initialization code of
@scheme[frame:basic-mixin].
@itemize[@item{If it is @scheme[#f], then its value is
ignored.}
@item{It it is a @scheme[bitmap%], then the @method[frame% set-icon] is called
with the bitmap, the result of invoking the @scheme[bitmap% get-loaded-mask] method,
and @scheme['both].}
@item{If it is a pair of bitmaps, then the @method[frame% set-icon]
method is invoked twice, once with each bitmap in the pair. The first bitmap
is passed (along with the result of its @scheme[bitmap% get-loaded-mask])
and @scheme['small], and then the second bitmap is passed
(also along with the result of its @scheme[bitmap% get-loaded-mask]) and @scheme['large].}]
Defaults to @scheme[#f].})
(proc-doc/names
group:get-the-frame-group
(-> (is-a?/c group:%))

View File

@ -201,6 +201,16 @@
(accept-drop-files #t)
(inherit set-icon)
(let ([icon (current-icon)])
(when icon
(if (pair? icon)
(let ([small (car icon)]
[large (cdr icon)])
(set-icon small (send small get-loaded-mask) 'small)
(set-icon large (send large get-loaded-mask) 'large))
(set-icon icon (send icon get-loaded-mask) 'both))))
(let ([mb (make-object (get-menu-bar%) this)])
(when (or (eq? (system-type) 'macos)
(eq? (system-type) 'macosx))
@ -213,6 +223,8 @@
(define/public (get-area-container) panel)
(set! after-init? #t)))
(define current-icon (make-parameter #f))
(define size-pref<%>
(interface (basic<%>)))

View File

@ -294,7 +294,8 @@
text-info-mixin
pasteboard-info-mixin))
(define-signature frame^ extends frame-class^
(reorder-menus
(current-icon
reorder-menus
remove-empty-menus
add-snip-menu-items
setup-size-pref))

View File

@ -107,7 +107,7 @@
object returned by
@scheme[group:get-the-frame-group].
Do not give @scheme[panel%]s or @scheme[control<%>]s this frame as
Do not give @scheme[panel%] or @scheme[control<%>] objects this frame as
parent. Instead, use the result of the
@method[frame:basic<%> get-area-container]
method.
@ -118,6 +118,11 @@
@method[frame:basic<%> get-menu-bar%]. It only passes the frame as an initialization argument.
In addition, it creates the windows menu in the menu bar.
This mixin calls its @method[window<%> accept-drop-files] with @scheme[#t].
It also calls its @method[frame% set-icon] method according to the current
value of @scheme[frame:current-icon].
See also
@scheme[frame:reorder-menus].
@defmethod*[#:mode override (((show (on? boolean?)) void))]{