FranzCross: add xmas icon

FranzCross/common.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
-(require (prefix-in gui: racket/gui)
+(require racket/format
+         (prefix-in gui: racket/gui)
          racket/gui/easy/color
          racket/gui/easy/font
          racket/runtime-path)
@@ -93,6 +94,7 @@
   code.png
   gear.png
   icon_512x512.png
+  icon-xmas
   pause.png
   play.png
   plus.png
@@ -114,3 +116,12 @@
   [play-bmp play.png]
   [plus-bmp plus.png]
   [viewfinder-ellipsis-bmp viewfinder-ellipsis.png])
+
+(provide
+ xmas-icon-bmps)
+
+(define xmas-icon-bmps
+  (for/vector ([i (in-range 25)])
+    (define path
+      (build-path icon-xmas (format "icon-~a.png" (~r i #:min-width 2 #:pad-string "0"))))
+    (gui:read-bitmap #:try-@2x? #t path)))

FranzCross/welcome-window.rkt

@@ -6,10 +6,13 @@
          (prefix-in p: pict)
          racket/gui/easy
          racket/gui/easy/operator
+         racket/math
          (prefix-in ~ threading)
          "canvas-list.rkt"
          "common.rkt"
-         "mixin.rkt")
+         "mixin.rkt"
+         "observable.rkt"
+         "xmas-icon.rkt")
 
 (provide
  welcome-window)
@@ -25,9 +28,11 @@
    (hpanel
     (vpanel
      #:alignment '(center center)
-     (image
-      #:size '(128 128)
-      icon_512x512.png)
+     (if xmas?
+         (xmas-icon)
+         (image
+          #:size '(128 128)
+          icon_512x512.png))
      (text
       #:font system-font-xl
       "Welcome to Franz")

FranzCross/xmas-icon.rkt

@@ -0,0 +1,51 @@
+#lang racket/gui/easy
+
+(require racket/class
+         racket/math
+         "common.rkt"
+         "observable.rkt")
+
+(provide
+ xmas?
+ xmas-icon)
+
+(define xmas?
+  (let ([d (seconds->date (current-seconds))])
+    (define c (+ (* (date-month d) 100) (date-day d)))
+    (or (<= c  115)
+        (>= c 1115))))
+
+(define (xmas-icon)
+  (define-observables
+    [@xmas-tick 0])
+  (define tick-thd
+    (void
+     (thread
+      (lambda ()
+        (define r (* 2 (/ 1 25.0)))
+        (define t (current-inexact-monotonic-milliseconds))
+        (let loop ()
+          (@xmas-tick:=
+           (exact-round
+            (/ (- (current-inexact-monotonic-milliseconds) t)
+               (* 1000 r))))
+          (sleep r)
+          (loop))))))
+  (add-hooks
+   #:on-destroy
+   (lambda ()
+     (kill-thread tick-thd))
+   (canvas
+    @xmas-tick
+    #:style '(transparent)
+    #:stretch '(#f #f)
+    #:min-size '(128 128)
+    (lambda (dc tick)
+      (define idx (modulo tick (vector-length xmas-icon-bmps)))
+      (define bmp (vector-ref xmas-icon-bmps idx))
+      (send dc draw-bitmap bmp 0 0)))))
+
+(module+ main
+  (render
+   (window
+    (xmas-icon))))