adjust the dock icon (under mac os x) to change on the weekends

collects/drracket/private/dock-icon.rkt

@@ -0,0 +1,22 @@
+#lang racket/base
+(provide set-dock-tile-bitmap)
+(require ffi/unsafe/objc
+         ffi/unsafe/atomic
+         mred/private/wx/cocoa/image
+         mred/private/wx/cocoa/utils)
+
+(import-class NSApplication
+              NSImageView)
+
+(define (set-dock-tile-bitmap bm)
+  (when (eq? (system-type) 'macosx)
+    (unless old-cocoa?
+      (define dock-tile (tell (tell NSApplication sharedApplication) dockTile))
+      (start-atomic)
+      (define view (tell (tell NSImageView alloc) init))
+      (tellv view setImage: (bitmap->image bm))
+      
+      (tellv dock-tile setContentView: view)
+      (tellv dock-tile display)
+      (tellv view release)
+      (end-atomic))))

collects/drracket/private/drracket-normal.rkt

@@ -7,6 +7,7 @@
          framework/private/bday
          framework/splash
          racket/file
+         "dock-icon.rkt"
          "frame-icon.rkt"
          "eb.rkt")
 
@@ -30,7 +31,6 @@
 
 (define high-color? ((get-display-depth) . > . 8))
 (define special-state #f)
-(define normal-bitmap #f) ; set by load-magic-images
 
 (define (icons-bitmap name)
   (make-object bitmap% (collection-file-path name "icons")))
@@ -48,13 +48,6 @@
 
 (define (load-magic-images)
   (set! load-magic-images void) ; run only once
-  (unless normal-bitmap 
-    (set! normal-bitmap
-          (cond
-            [(path? normal-bitmap-spec)
-             (make-object bitmap% normal-bitmap-spec)]
-            [else
-             (make-object bitmap% (collection-file-path "plt-logo-red-diffuse.png" "icons"))])))
   (for-each (λ (magic-image)
               (unless (magic-image-bitmap magic-image)
                 (set-magic-image-bitmap!
@@ -81,25 +74,24 @@
   (when ((length key-codes) . > . longest-magic-string)
     (set! key-codes (take key-codes longest-magic-string))))
 
-(set-splash-char-observer
+(define (drracket-splash-char-observer evt)
- (λ (evt)
+  (let ([ch (send evt get-key-code)])
-   (let ([ch (send evt get-key-code)])
+    (when (and (eq? ch #\q)
-     (when (and (eq? ch #\q)
+               (send evt get-control-down))
-                (send evt get-control-down))
+      (exit))
-       (exit))
+    (when (char? ch)
-     (when (char? ch)
+      ;; as soon as something is typed, load the bitmaps
-       ;; as soon as something is typed, load the bitmaps
+      (load-magic-images)
-       (load-magic-images)
+      (add-key-code ch)
-       (add-key-code ch)
+      (let ([match (find-magic-image)])
-       (let ([match (find-magic-image)])
+        (when match
-         (when match
+          (set! key-codes null)
-           (set! key-codes null)
+          (set-splash-bitmap
-           (set-splash-bitmap
+           (if (eq? special-state match)
-            (if (eq? special-state match)
+               (begin (set! special-state #f) normal-bitmap)
-                (begin (set! special-state #f) normal-bitmap)
+               (begin (set! special-state match)
-                (begin (set! special-state match)
+                      (magic-image-bitmap match))))
-                       (magic-image-bitmap match))))
+          (refresh-splash))))))
-           (refresh-splash)))))))
 
 (when (eb-bday?) (install-eb))
 
@@ -125,7 +117,11 @@
      (collection-file-path "pltbw.gif" "icons")]
     [else
      (collection-file-path "plt-flat.gif" "icons")]))
-(start-splash normal-bitmap-spec
+(define normal-bitmap (read-bitmap normal-bitmap-spec))
+(set-splash-char-observer drracket-splash-char-observer)
+(when (and high-color? weekend?)
+  (set-dock-tile-bitmap normal-bitmap))
+(start-splash normal-bitmap
               "DrRacket"
               700
               #:allow-funny? #t