fixup the heart bitmap so it has an alpha channel and then add it into the weekend/weekday rotation

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"

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