suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r16529
This commit is contained in:
Robby Findler 2009-11-03 20:50:50 +00:00
parent 829c6d783f
commit 8886736b76
5 changed files with 204 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/drscheme/private/app.ss
View File

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

218
collects/drscheme/private/drscheme-normal.ss
View File

@ -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?)
(let ()
(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)))
(define eb-today? (eb-bday?))
(when eb-today? (install-eb))
;; 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]
[high-end (* (+ stages pause-time)
(- (length plt-logo-evolution) 1))])
(min (max (floor (* (+ high-end 1) (/ val range)))
low-end)
high-end)))
(min (max (floor (* (+ evolution-last-stage 1) (/ val range)))
0)
evolution-last-stage))
(define (update-bitmap-stage val range)
(let* ([index (logo-index val range)]
[q (quotient index (+ stages pause-time))]
(update-bitmap-stage/index (logo-index val range)))
(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)))
(vector splash-evolution w h))]
(unless eb-today?
(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

146
collects/drscheme/private/eb.ss Normal file
View File

@ -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))

2
collects/drscheme/tool-lib.ss
View File

@ -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)

3
collects/framework/splash.ss
View File

@ -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)