improved the icon a little bit more (making it appear on more windows)
svn: r17380
This commit is contained in:
parent
b4060f7157
commit
3272274f53
|
@ -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)
|
||||
|
|
|
@ -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%
|
||||
|
|
|
@ -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:%))
|
||||
|
|
|
@ -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<%>)))
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))]{
|
||||
|
|
Loading…
Reference in New Issue
Block a user