attempted to smooth out the splash screen animation by using wall clock times (via current-milliseconds)

svn: r16529

collects/drscheme/private/app.ss

@@ -75,7 +75,7 @@
     (build-path (collection-path "icons")
                 (if (< (get-display-depth) 8)
                     "pltbw.gif"
-                    "PLT-206.png"))))
+                    "plt-logo-red-shiny.png"))))
 
 
 

collects/drscheme/private/drscheme-normal.ss

@@ -5,7 +5,9 @@
          scheme/cmdline
          scheme/list
          framework/private/bday
-         framework/splash)
+         framework/splash
+         scheme/file
+         "eb.ss")
 
 (define files-to-open (command-line #:args filenames filenames))
 
@@ -87,152 +89,13 @@
                 (begin (set! special-state match)
                        (magic-image-bitmap match))))))))))
 
-(when (eb-bday?)
+(define eb-today? (eb-bday?))
-  (let ()
+(when eb-today? (install-eb))
-    (define main-size 260)
-    (define pi (atan 0 -1))
-    
-    (define eli (icons-bitmap "eli-purple.jpg"))
-    (define bitmap (make-object bitmap% main-size main-size))
-    (define bdc (make-object bitmap-dc% bitmap))
-    
-    (define outer-color (send the-color-database find-color "darkorange"))
-    (define inner-color (send the-color-database find-color "green"))
-    (define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
-    (define hebrew-str "  ףוס ןיא  ףוס ןיא")
-    
-    (define (draw-letter dc cx cy angle radius letter color)
-      (let ([x (+ cx (* (cos angle) radius))]
-            [y (- cy (* (sin angle) radius))])
-        (send bdc set-text-foreground color)
-        (send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
-    
-    (define (draw-single-loop str dc offset cx cy radius font-size color)
-      (send dc set-font (send the-font-list find-or-create-font font-size 'modern))
-      (let loop ([i (string-length str)])
-        (unless (zero? i)
-          (draw-letter dc 
-                       cx 
-                       cy 
-                       (normalize-angle
-                        (+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
-                           (/ pi 2)
-                           offset))
-                       radius
-                       (string (string-ref str (- i 1)))
-                       color)
-          (loop (- i 1)))))
-    
-    (define (normalize-angle angle)
-      (cond
-        [(<= 0 angle (* 2 pi)) angle]
-        [(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
-        [else (normalize-angle (- angle (* 2 pi)))]))
-    
-    (define splash-canvas (get-splash-canvas))
-    (define (draw-single-step dc offset)
-      (send bdc draw-bitmap eli 0 0)
-      (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
-      (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
-      (send splash-canvas on-paint))
-    
-    (define gc-b
-      (with-handlers ([exn:fail? (lambda (x)
-                                   (printf "~s\n" (exn-message x))
-                                   #f)])
-        (let ([b (icons-bitmap "recycle.gif")])
-          (cond
-            [(send b ok?)
-             (let ([gbdc (make-object bitmap-dc% b)]
-                   [ebdc (make-object bitmap-dc% eli)]
-                   [color1 (make-object color%)]
-                   [color2 (make-object color%)]
-                   [avg (lambda (x y) (floor (* (/ x 255) y)))]
-                   [ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
-                   [oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
-               (let loop ([i (send b get-width)])
-                 (unless (zero? i)
-                   (let loop ([j (send b get-height)])
-                     (unless (zero? j)
-                       (let ([x (- i 1)]
-                             [y (- j 1)])
-                         (send gbdc get-pixel x y color1)
-                         (send ebdc get-pixel (+ x ox) (+ y oy) color2)
-                         (send color1 set 
-                               (avg (send color1 red) (send color2 red))
-                               (avg (send color1 green) (send color2 green))
-                               (avg (send color1 blue) (send color2 blue)))
-                         (send gbdc set-pixel x y color1)
-                         (loop (- j 1)))))
-                   (loop (- i 1))))
-               (send gbdc set-bitmap #f)
-               (send ebdc set-bitmap #f)
-               b)]
-            [else #f]))))
-    
-    
-    (define (eli-paint dc)
-      (send dc draw-bitmap bitmap 0 0))
-    (define (eli-event evt)
-      (cond
-        [(send evt leaving?)
-         (set-splash-paint-callback orig-paint)
-         (when gc-b
-           (unregister-collecting-blit splash-canvas))
-         (send splash-canvas refresh)
-         (when draw-thread
-           (kill-thread draw-thread)
-           (set! draw-thread #f))]
-        [(send evt entering?)
-         (set-splash-paint-callback eli-paint)
-         (when gc-b
-           (register-collecting-blit splash-canvas 
-                                     (floor (- (/ main-size 2)
-                                               (/ (send gc-b get-width) 2)))
-                                     (floor (- (/ main-size 2)
-                                               (/ (send gc-b get-height) 2)))
-                                     (send gc-b get-width)
-                                     (send gc-b get-height)
-                                     gc-b gc-b))
-         (send splash-canvas refresh)
-         (unless draw-thread
-           (start-thread))]))
-    
-    (define splash-eventspace (get-splash-eventspace))
-    (define draw-next-state
-      (let ([o 0])
-        (lambda ()
-          (let ([s (make-semaphore 0)])
-            (parameterize ([current-eventspace splash-eventspace])
-              (queue-callback 
-               (λ () 
-                 (draw-single-step bdc o)
-                 (semaphore-post s))))
-            (semaphore-wait s))
-          (let ([next (+ o (/ pi 60))])
-            (set! o (if (< next (* 2 pi))
-                        next
-                        (- next (* 2 pi))))))))
-    
-    (define draw-thread #f)
-    (define (start-thread)        
-      (set! draw-thread
-            (thread
-             (λ ()
-               (let loop ()
-                 (draw-next-state)
-                 (sleep .01)
-                 (loop))))))
-    (define orig-paint (get-splash-paint-callback))
-    
-    (draw-next-state)
-    (set-splash-event-callback eli-event)
-    (send splash-canvas refresh)))
 
 ;; assumes that the width & height of all of the bitmaps
 ;; in this list are the same.
 (define plt-logo-evolution
-  (map (λ (x) (make-object bitmap% (build-path (collection-path "icons") x)))
+  (map icons-bitmap
        '("plt-logo-red-flat.png"
          "plt-logo-red-gradient.png"
          "plt-logo-red-diffuse.png"
@@ -246,11 +109,11 @@
 (define interpolate-evolution-bdc (make-object bitmap-dc%))
 
 ;; number of greyscale stages (between the logos above)
-(define stages 4)
+(define stages 5)
 
 ;; number of increments (per cycle) to dedicate to 
 ;; an unfaded version of the logos. must be > 0.
-(define pause-time 4)
+(define pause-time 2)
 
 (define stage-bitmaps
   (cond
@@ -273,17 +136,20 @@
               (cons bm (loop (+ i 1))))])))]
     [else '()]))
 
+(define evolution-last-stage 
+  (* (+ stages pause-time) 
+     (- (length plt-logo-evolution) 1)))
+
 (define (logo-index val range)
-  (let ([low-end 0]
+  (min (max (floor (* (+ evolution-last-stage 1) (/ val range))) 
-        [high-end (* (+ stages pause-time) 
+            0)
-                     (- (length plt-logo-evolution) 1))])
+       evolution-last-stage))
-    (min (max (floor (* (+ high-end 1) (/ val range))) 
-              low-end)
-         high-end)))
 
 (define (update-bitmap-stage val range)
-  (let* ([index (logo-index val range)]
+  (update-bitmap-stage/index (logo-index val range)))
-         [q (quotient index (+ stages pause-time))]
+
+(define (update-bitmap-stage/index index)
+  (let* ([q (quotient index (+ stages pause-time))]
          [m (modulo index (+ stages pause-time))])
     (cond
       [(< m pause-time)
@@ -315,6 +181,14 @@
         0
         0))
 
+(define start-time (current-milliseconds))
+(define last-times-delta 
+  (let ([pref (get-preference 'plt:drscheme-splash-timing)])
+    (and pref
+         (pair? pref)
+         (equal? (car pref) (version))
+         (cdr pref))))
+
 (start-splash
  (cond
    [(or prince-kuhio-day? kamehameha-day?)
@@ -329,14 +203,6 @@
     (build-path (collection-path "icons") "PLT-pumpkin.png")]
    [(and high-color?  
          (send (car plt-logo-evolution) ok?))
-    (set-refresh-splash-on-gauge-change?! 
-     (λ (val range) 
-       (cond
-         [(equal? (logo-index val range) (logo-index (- val 1) range))
-          #f]
-         [else
-          (update-bitmap-stage val range)
-          #t])))
     (let ([gc-bm (make-object bitmap% (build-path (collection-path "icons") "recycle.png") 'png/mask)]
           [w (send (car plt-logo-evolution) get-width)]
           [h (send (car plt-logo-evolution) get-height)])
@@ -347,8 +213,27 @@
                [bdc (make-object bitmap-dc% off-bm)])
           (send bdc clear)
           (send bdc set-bitmap #f)
-          (register-collecting-blit (get-splash-canvas) (- w gc-w 2) 2 gc-w gc-h gc-bm off-bm)))
+          (unless eb-today?
-      (vector splash-evolution w h))]
+            (register-collecting-blit (get-splash-canvas) (- w gc-w 2) 2 gc-w gc-h gc-bm off-bm))))
+      (cond
+        [last-times-delta
+         (thread
+          (λ () 
+            (let loop ([i 0])
+              (when (<= i evolution-last-stage)
+                (let* ([now (current-milliseconds)]
+                       [next-stage-start (+ start-time (* last-times-delta (/ i (+ evolution-last-stage 1))))]
+                       [delta (- next-stage-start now)])
+                  (sleep (max 0 (/ delta 1000))))
+                (parameterize ([current-eventspace (get-splash-eventspace)])
+                  (queue-callback
+                   (λ () 
+                     (update-bitmap-stage/index i)
+                     (refresh-splash))))
+                (loop (+ i 1))))))
+         (vector splash-evolution w h)]
+        [else
+         (build-path (collection-path "icons") "plt-logo-red-shiny.png")]))]
    [high-color?
     (build-path (collection-path "icons") "PLT-206.png")]
    [(= (get-display-depth) 1)
@@ -378,3 +263,10 @@
         (send f show #t)))))
 
 (dynamic-require 'drscheme/tool-lib #f)
+
+(define end-time (current-milliseconds))
+(shutdown-splash)
+(close-splash)
+(put-preferences '(plt:drscheme-splash-timing)
+                 (list (cons (version) (* .8 (- end-time start-time))))
+                 void) ;; swallow errors 

collects/drscheme/private/eb.ss

@@ -0,0 +1,146 @@
+#lang scheme/base
+(require scheme/class
+         framework/splash
+         scheme/gui/base)
+
+(provide install-eb)
+(define (install-eb)
+  (define main-size 260)
+  (define pi (atan 0 -1))
+  
+  (define eli (make-object bitmap% (build-path (collection-path "icons") "eli-purple.jpg")))
+  (define bitmap (make-object bitmap% main-size main-size))
+  (define bdc (make-object bitmap-dc% bitmap))
+  
+  (define outer-color (send the-color-database find-color "darkorange"))
+  (define inner-color (send the-color-database find-color "green"))
+  (define omega-str "(λ (x) (x x)) (λ (x) (x x)) ")
+  (define hebrew-str "  ףוס ןיא  ףוס ןיא")
+  
+  (define (draw-letter dc cx cy angle radius letter color)
+    (let ([x (+ cx (* (cos angle) radius))]
+          [y (- cy (* (sin angle) radius))])
+      (send bdc set-text-foreground color)
+      (send dc draw-text letter x y #f 0 (- angle (/ pi 2)))))
+  
+  (define (draw-single-loop str dc offset cx cy radius font-size color)
+    (send dc set-font (send the-font-list find-or-create-font font-size 'modern))
+    (let loop ([i (string-length str)])
+      (unless (zero? i)
+        (draw-letter dc 
+                     cx 
+                     cy 
+                     (normalize-angle
+                      (+ (- (* 2 pi) (* (* 2 pi) (/ (- i 1) (string-length str))))
+                         (/ pi 2)
+                         offset))
+                     radius
+                     (string (string-ref str (- i 1)))
+                     color)
+        (loop (- i 1)))))
+  
+  (define (normalize-angle angle)
+    (cond
+      [(<= 0 angle (* 2 pi)) angle]
+      [(< angle 0) (normalize-angle (+ angle (* 2 pi)))]
+      [else (normalize-angle (- angle (* 2 pi)))]))
+  
+  (define splash-canvas (get-splash-canvas))
+  (define (draw-single-step dc offset)
+    (send bdc draw-bitmap eli 0 0)
+    (draw-single-loop omega-str bdc offset (/ main-size 2) (/ main-size 2) 120 32 outer-color)
+    (draw-single-loop hebrew-str bdc (+ (- (* 2 pi) offset) (* 2 pi)) (/ main-size 2) (/ main-size 2) 70 20 inner-color)
+    (send splash-canvas on-paint))
+  
+  (define gc-b
+    (with-handlers ([exn:fail? (lambda (x)
+                                 (printf "~s\n" (exn-message x))
+                                 #f)])
+      (let ([b (make-object bitmap% (build-path (collection-path "icons") "recycle.gif"))])
+        (cond
+          [(send b ok?)
+           (let ([gbdc (make-object bitmap-dc% b)]
+                 [ebdc (make-object bitmap-dc% eli)]
+                 [color1 (make-object color%)]
+                 [color2 (make-object color%)]
+                 [avg (lambda (x y) (floor (* (/ x 255) y)))]
+                 [ox (floor (- (/ main-size 2) (/ (send b get-width) 2)))]
+                 [oy (floor (- (/ main-size 2) (/ (send b get-height) 2)))])
+             (let loop ([i (send b get-width)])
+               (unless (zero? i)
+                 (let loop ([j (send b get-height)])
+                   (unless (zero? j)
+                     (let ([x (- i 1)]
+                           [y (- j 1)])
+                       (send gbdc get-pixel x y color1)
+                       (send ebdc get-pixel (+ x ox) (+ y oy) color2)
+                       (send color1 set 
+                             (avg (send color1 red) (send color2 red))
+                             (avg (send color1 green) (send color2 green))
+                             (avg (send color1 blue) (send color2 blue)))
+                       (send gbdc set-pixel x y color1)
+                       (loop (- j 1)))))
+                 (loop (- i 1))))
+             (send gbdc set-bitmap #f)
+             (send ebdc set-bitmap #f)
+             b)]
+          [else #f]))))
+  
+  
+  (define (eli-paint dc)
+    (send dc draw-bitmap bitmap 0 0))
+  (define (eli-event evt)
+    (cond
+      [(send evt leaving?)
+       (set-splash-paint-callback orig-paint)
+       (when gc-b
+         (unregister-collecting-blit splash-canvas))
+       (send splash-canvas refresh)
+       (when draw-thread
+         (kill-thread draw-thread)
+         (set! draw-thread #f))]
+      [(send evt entering?)
+       (set-splash-paint-callback eli-paint)
+       (when gc-b
+         (register-collecting-blit splash-canvas 
+                                   (floor (- (/ main-size 2)
+                                             (/ (send gc-b get-width) 2)))
+                                   (floor (- (/ main-size 2)
+                                             (/ (send gc-b get-height) 2)))
+                                   (send gc-b get-width)
+                                   (send gc-b get-height)
+                                   gc-b gc-b))
+       (send splash-canvas refresh)
+       (unless draw-thread
+         (start-thread))]))
+  
+  (define splash-eventspace (get-splash-eventspace))
+  (define draw-next-state
+    (let ([o 0])
+      (lambda ()
+        (let ([s (make-semaphore 0)])
+          (parameterize ([current-eventspace splash-eventspace])
+            (queue-callback 
+             (λ () 
+               (draw-single-step bdc o)
+               (semaphore-post s))))
+          (semaphore-wait s))
+        (let ([next (+ o (/ pi 60))])
+          (set! o (if (< next (* 2 pi))
+                      next
+                      (- next (* 2 pi))))))))
+  
+  (define draw-thread #f)
+  (define (start-thread)        
+    (set! draw-thread
+          (thread
+           (λ ()
+             (let loop ()
+               (draw-next-state)
+               (sleep .01)
+               (loop))))))
+  (define orig-paint (get-splash-paint-callback))
+  
+  (draw-next-state)
+  (set-splash-event-callback eli-event)
+  (send splash-canvas refresh))

collects/drscheme/tool-lib.ss

@@ -29,8 +29,6 @@ all of the names in the tools library, for use defining keybindings
 (require/doc (for-label errortrace/errortrace-key))
 
 (define-values/invoke-unit/infer drscheme@)
-(shutdown-splash)
-(close-splash)
 (provide-signature-elements drscheme:tool-cm^) ;; provide all of the classes & interfaces
 
 (provide drscheme:unit:program-editor-mixin)

collects/framework/splash.ss

@@ -20,7 +20,8 @@
          get-splash-event-callback
          set-refresh-splash-on-gauge-change?!
          get-splash-width
-         get-splash-height)
+         get-splash-height
+         refresh-splash)
 
 (define splash-bitmap #f)
 (define splash-cache-bitmap #f)