added a valentine's day splash screen image

collects/drracket/private/drracket-normal.rkt

@@ -15,7 +15,7 @@
 ;; to open. See also main.rkt.
 (current-command-line-arguments (apply vector files-to-open))
 
-(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween? weekend?)
+(define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween? valentines-day? weekend?)
   (let* ([date (seconds->date (current-seconds))]
          [month (date-month date)]
          [day (date-day date)]
@@ -24,6 +24,7 @@
             (and (= 3 month) (= 26 day))
             (and (= 6 month) (= 11 day))
             (and (= 10 month) (= 31 day))
+            (and (= 2 month) (= 14 day))
             (or (= dow 6) (= dow 0)))))
 
 (define high-color? ((get-display-depth) . > . 8))
@@ -98,7 +99,9 @@
 
 (start-splash
  (cond
-   [(or prince-kuhio-day? kamehameha-day?)
+   [(and valentines-day? high-color?)
+    (build-path (collection-path "icons") "heart.png")]
+   [(and (or prince-kuhio-day? kamehameha-day?) high-color?)
     (set-splash-progress-bar? #f)
     (let ([size ((dynamic-require 'drracket/private/palaka 'palaka-pattern-size) 4)])
       (vector (dynamic-require 'drracket/private/honu-logo 'draw-honu) 

collects/icons/private/mkheart.rkt

@@ -0,0 +1,56 @@
+#lang racket/gui
+(require mrlib/private/image-core-bitmap)
+(define img (make-object bitmap% "/Users/robby/git/plt/collects/icons/plt-logo-red-shiny.png"))
+;(define img (make-object bitmap% "/Users/robby/git/plt/collects/icons/foot.png"))
+(define-values (bmbytes bm-w bm-h) (bitmap->bytes img))
+(printf "transforming\n")
+
+(define amount .5)
+(define remove-margin 50)
+
+(define-values (left-bytes left-w left-h) (linear-transform bmbytes bm-w bm-h 1 0 (- amount) 1))
+(define-values (right-bytes right-w right-h) (linear-transform bmbytes bm-w bm-h 1 0 amount 1))
+(define left-bm (bytes->bitmap left-bytes left-w left-h))
+(define right-bm (bytes->bitmap right-bytes right-w right-h))
+(define f (new frame% [label ""]))
+(define hp (new horizontal-panel% [parent f] [alignment '(center center)]))
+
+(define heart-w left-w)
+(define heart-h (- left-h remove-margin remove-margin))
+
+(define (draw-heart dc)
+  (send dc draw-bitmap-section 
+        left-bm 
+        0 (- remove-margin) 
+        0 0
+        (floor (/ heart-w 2)) left-h)
+  (send dc draw-bitmap-section 
+        right-bm
+        (floor (/ heart-w 2)) (- remove-margin) 
+        (floor (/ heart-w 2)) 0
+        (floor (/ heart-w 2)) right-h))
+
+(define corig (new canvas%
+               [parent hp]
+               [min-width bm-w]
+               [min-height bm-h]
+               [stretchable-height #f]
+               [paint-callback
+                (λ (c dc)
+                  (send dc draw-bitmap img 0 0))]))
+(define c (new canvas%
+               [parent hp]
+               [min-width heart-w]
+               [min-height heart-h]
+               [paint-callback
+                (λ (c dc)
+                  (draw-heart dc))]))
+(void (new grow-box-spacer-pane% [parent f]))
+(send f show #t)
+
+(define heart-bm (make-object 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)
+(send heart-bm save-file (build-path (collection-path "icons") "heart.png") 'png)