diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss new file mode 100644 index 00000000..2ebd821a --- /dev/null +++ b/collects/framework/private/bday.ss @@ -0,0 +1,17 @@ +(module bday mzscheme + (provide mrf-bday? + mf-bday?) + + ;; mf-bday? : -> boolean + ;; Matthias's birthday + (define (mf-bday?) + (let ([date (seconds->date (current-seconds))]) + (and (= (date-month date) 10) + (= (date-day date) 29)))) + + ;; mrf-bday? : -> boolean + ;; Matthew's birthday + (define (mrf-bday?) + (let ([d (seconds->date (current-seconds))]) + (and (= (date-month d) 11) + (= (date-day d) 1))))) \ No newline at end of file diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index a3e7513c..74dc83b7 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -8,6 +8,7 @@ "sig.ss" "../gui-utils.ss" "../macro.ss" + "bday.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") (lib "file.ss") @@ -441,7 +442,7 @@ (send panel stretchable-width #f))) [define lock-canvas (make-object lock-canvas% (get-info-panel))] - [define gc-canvas (make-object canvas% (get-info-panel) '(border))] + [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] [define register-gc-blit (lambda () (let ([onb (icon:get-gc-on-bitmap)] @@ -2060,6 +2061,18 @@ (super-can-close?))))] (super-instantiate ()))) + (define bday-click-canvas% + (class canvas% + (rename [super-on-event on-event]) + (define/override (on-event evt) + (cond + [(and (mrf-bday?) + (send evt button-up?)) + (message-box (string-constant drscheme) + "Happy Birthday, Matthew!")] + [else (super-on-event evt)])) + (super-instantiate ()))) + (define basic% (basic-mixin frame%)) (define info% (info-mixin basic%)) (define text-info% (text-info-mixin info%)) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index 67dc7c1d..11864ff2 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -1,7 +1,8 @@ (module icon mzscheme (require (lib "unitsig.ss") (lib "class.ss") - "sig.ss" + "bday.ss" + "sig.ss" (lib "mred-sig.ss" "mred") (lib "mred-sig.ss" "mred")) @@ -80,11 +81,6 @@ ((load-icon "mrf.jpg" 'jpeg)) ((load-icon "recycle.gif" 'gif)))))) - (define (mrf-bday?) - (let ([d (seconds->date (current-seconds))]) - (and (= (date-month d) 11) - (= (date-day d) 1)))) - (define (get-gc-on-bitmap) (fetch) gc-on-bitmap) (define get-gc-off-bitmap