diff --git a/collects/drracket/private/drracket-normal.rkt b/collects/drracket/private/drracket-normal.rkt index e55b3f2d18..369bf84662 100644 --- a/collects/drracket/private/drracket-normal.rkt +++ b/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) diff --git a/collects/icons/heart.png b/collects/icons/heart.png new file mode 100644 index 0000000000..a06d9a9bd3 Binary files /dev/null and b/collects/icons/heart.png differ diff --git a/collects/icons/private/mkheart.rkt b/collects/icons/private/mkheart.rkt new file mode 100644 index 0000000000..8198954b9d --- /dev/null +++ b/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)