diff --git a/collects/drracket/private/drracket-normal.rkt b/collects/drracket/private/drracket-normal.rkt index 1971aa1262..cd2455ac83 100644 --- a/collects/drracket/private/drracket-normal.rkt +++ b/collects/drracket/private/drracket-normal.rkt @@ -24,7 +24,18 @@ (define dow (date-week-day date)) (or (= dow 6) (= dow 0))) -(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween? valentines-day?) +(define (valentines-day?) + (define date (seconds->date (current-seconds))) + (and (= 2 (date-month date)) + (= 14 (date-day date)))) + +(define (current-icon-state) + (cond + [(valentines-day?) 'valentines] + [(currently-the-weekend?) 'weekend] + [else 'normal])) + +(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) (let* ([date (seconds->date (current-seconds))] [month (date-month date)] [day (date-day date)] @@ -32,8 +43,7 @@ (values (and (= 3 month) (= 2 day)) (and (= 3 month) (= 26 day)) (and (= 6 month) (= 11 day)) - (and (= 10 month) (= 31 day)) - (and (= 2 month) (= 14 day))))) + (and (= 10 month) (= 31 day))))) (define special-state #f) @@ -103,11 +113,12 @@ (define weekend-bitmap-spec (collection-file-path "plt-logo-red-shiny.png" "icons")) (define normal-bitmap-spec (collection-file-path "plt-logo-red-diffuse.png" "icons")) +(define valentines-days-spec (collection-file-path "heart.png" "icons")) (define the-bitmap-spec (cond - [valentines-day? - (collection-file-path "heart.png" "icons")] + [(valentines-day?) + valentines-days-spec] [(or prince-kuhio-day? kamehameha-day?) (set-splash-progress-bar?! #f) (let ([size ((dynamic-require 'drracket/private/palaka 'palaka-pattern-size) 4)]) @@ -125,30 +136,38 @@ (set-splash-char-observer drracket-splash-char-observer) (when (eq? (system-type) 'macosx) - (define initially-the-weekend? (currently-the-weekend?)) + (define initial-state (current-icon-state)) (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec) the-splash-bitmap #f)) (define weekday-bitmap (if (equal? the-bitmap-spec normal-bitmap-spec) the-splash-bitmap #f)) + (define valentines-bitmap (if (equal? the-bitmap-spec valentines-days-spec) + the-splash-bitmap + #f)) (define set-doc-tile-bitmap (dynamic-require doc-icon.rkt 'set-dock-tile-bitmap)) - (define (set-weekend) - (unless weekend-bitmap (set! weekend-bitmap (read-bitmap weekend-bitmap-spec))) - (set-doc-tile-bitmap weekend-bitmap)) - (define (set-weekday) - (unless weekday-bitmap (set! weekday-bitmap (read-bitmap normal-bitmap-spec))) - (set-doc-tile-bitmap weekday-bitmap)) - (when initially-the-weekend? (set-weekend)) + (define (set-icon state) + (case state + [(valentines) + (unless valentines-bitmap (set! valentines-bitmap (read-bitmap valentines-days-spec))) + (set-doc-tile-bitmap valentines-bitmap)] + [(weekend) + (unless weekend-bitmap (set! weekend-bitmap (read-bitmap weekend-bitmap-spec))) + (set-doc-tile-bitmap weekend-bitmap)] + [(normal) + (unless weekday-bitmap (set! weekday-bitmap (read-bitmap normal-bitmap-spec))) + (set-doc-tile-bitmap weekday-bitmap)])) + (set-icon initial-state) (void (thread (λ () - (let loop ([last-check-weekend? initially-the-weekend?]) + (let loop ([last-state initial-state]) (sleep 10) - (define this-check-weekend? (currently-the-weekend?)) - (unless (equal? last-check-weekend? this-check-weekend?) - (if this-check-weekend? (set-weekend) (set-weekday))) - (loop this-check-weekend?)))))) + (define next-state (current-icon-state)) + (unless (equal? last-state next-state) + (set-icon next-state)) + (loop next-state)))))) (start-splash the-splash-bitmap "DrRacket" diff --git a/collects/icons/heart.png b/collects/icons/heart.png index a06d9a9bd3..ff911cf9fd 100644 Binary files a/collects/icons/heart.png and b/collects/icons/heart.png differ diff --git a/collects/icons/private/mkheart.rkt b/collects/icons/private/mkheart.rkt index 77c38caff8..e700c3d532 100644 --- a/collects/icons/private/mkheart.rkt +++ b/collects/icons/private/mkheart.rkt @@ -1,6 +1,6 @@ #lang racket/gui (require mrlib/private/image-core-bitmap) -(define img (make-object bitmap% (build-path (collection-path "icons") "plt-logo-red-shiny.png"))) +(define img (read-bitmap (build-path (collection-path "icons") "plt-logo-red-shiny.png"))) (define amount .5) (define remove-margin 50) @@ -46,9 +46,8 @@ (void (new grow-box-spacer-pane% [parent f])) (send f show #t) -(define heart-bm (make-object bitmap% heart-w heart-h)) +(define heart-bm (make-bitmap heart-w heart-h)) (define heart-bdc (make-object bitmap-dc% heart-bm)) -(send heart-bdc clear) (draw-heart heart-bdc) (send heart-bdc set-bitmap #f) ;; uncomment the next line to actually save the icon in the collects dir