a bunch of improvements to the splash screen (loads less code before the splash appears, got rid of a bunch of dynamic-requires that were not necessary, fixed the lack of special screen on prince kuhio and king kamehameha days, got rid of the flicker in the tools icons)

svn: r13980

original commit: 283c1819a92df7e6949ece8eebf659aac777583c
This commit is contained in:
Robby Findler 2009-03-06 16:35:04 +00:00
parent 7941bc4c3e
commit 809f38a3c9
4 changed files with 426 additions and 245 deletions

View File

@ -1,7 +1,6 @@
#lang mzscheme
(require framework/private/encode-decode)
(decode
#lang scheme/base
(require "decode.ss")
(decode
\5d8f4
\10ec22010
\45aff297b02

View File

@ -0,0 +1,43 @@
#lang scheme/base
(require (for-syntax mzlib/inflate
scheme/base))
(provide decode)
(define-syntax (decode stx)
(syntax-case stx ()
[(_ arg ...)
(andmap identifier? (syntax->list (syntax (arg ...))))
(let ()
(define (decode-sexp str)
(let* ([loc
(let loop ([chars (string->list str)])
(cond
[(null? chars) '()]
[(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")]
[else (let ([fst (to-digit (car chars))]
[snd (to-digit (cadr chars))])
(cons
(+ (* fst 16) snd)
(loop (cddr chars))))]))])
(let-values ([(p-in p-out) (make-pipe)])
(inflate (open-input-bytes (apply bytes loc)) p-out)
(read p-in))))
(define (to-digit char)
(cond
[(char<=? #\0 char #\9)
(- (char->integer char)
(char->integer #\0))]
[(char<=? #\a char #\f)
(+ 10 (- (char->integer char)
(char->integer #\a)))]))
(define decoded
(decode-sexp
(apply
string-append
(map (λ (x) (symbol->string (syntax-e x)))
(syntax->list (syntax (arg ...)))))))
(datum->syntax stx decoded stx))]))

View File

@ -0,0 +1,67 @@
#lang scheme/base
(require mzlib/deflate
mzlib/match
mzlib/pretty)
(require (for-syntax mzlib/inflate
mzlib/string))
(provide encode-sexp
encode-module)
(define (encode-module in-filename out-filename)
(call-with-input-file in-filename
(λ (port)
(let ([mod (read port)])
(unless (eof-object? (read port))
(error 'encode-module "found an extra expression"))
(match mod
[`(module ,m mzscheme ,@(bodies ...))
(call-with-output-file out-filename
(λ (oport)
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
(fprintf oport "(module ~a mzscheme\n" m)
(fprintf oport " (require framework/private/decode)\n")
(fprintf oport " (decode ~a" (car chopped))
(for-each (lambda (chopped)
(fprintf oport "\n ~a" chopped))
(cdr chopped))
(fprintf oport "))\n")))
'truncate 'text)]
[else (error 'encode-module "cannot parse module")])))))
(define (chop-up sym)
(let ([chopping-point 50])
(let loop ([str (symbol->string sym)])
(cond
[(<= (string-length str) chopping-point)
(list (string->symbol str))]
[else
(cons (string->symbol (substring str 0 chopping-point))
(loop (substring str chopping-point (string-length str))))]))))
(define (encode-sexp sexp)
(define (str->sym string)
(string->symbol
(apply
string-append
(map
(λ (x)
(to-hex x))
(bytes->list string)))))
(define (to-hex n)
(let ([digit->hex
(λ (d)
(cond
[(<= d 9) d]
[else (integer->char (+ d -10 (char->integer #\a)))]))])
(cond
[(< n 16) (format "0~a" (digit->hex n))]
[else (format "~a~a"
(digit->hex (quotient n 16))
(digit->hex (modulo n 16)))])))
(let ([in (open-input-string (format "~s" sexp))]
[out (open-output-bytes)])
(deflate in out)
(str->sym (get-output-bytes out))))

View File

@ -1,253 +1,325 @@
#lang scheme/base
(module splash mzscheme
(require mzlib/class
mzlib/file
mred)
(provide get-splash-bitmap
set-splash-bitmap
get-splash-canvas
get-splash-eventspace
start-splash
shutdown-splash
close-splash
add-splash-icon
set-splash-char-observer
set-splash-paint-callback
get-splash-paint-callback
set-splash-event-callback)
(define splash-filename #f)
(define splash-bitmap #f)
(define splash-eventspace (make-eventspace))
(define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm)
(set! splash-bitmap bm)
(send splash-canvas on-paint))
(define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace)
(require scheme/class
scheme/file
scheme/gui/base)
(define (set-splash-paint-callback pc) (set! splash-paint-callback pc))
(define (get-splash-paint-callback) splash-paint-callback)
(define (set-splash-event-callback ec) (set! splash-event-callback ec))
(provide get-splash-bitmap
set-splash-bitmap
get-splash-canvas
get-splash-eventspace
get-splash-paint-callback
set-splash-paint-callback
start-splash
shutdown-splash
close-splash
add-splash-icon
set-splash-progress-bar?
set-splash-char-observer
set-splash-event-callback
get-splash-event-callback
get-splash-width
get-splash-height)
(define splash-bitmap #f)
(define splash-cache-bitmap #f)
(define splash-cache-dc (make-object bitmap-dc%))
(define splash-eventspace (make-eventspace))
(define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm)
(set! splash-bitmap bm)
(send splash-canvas on-paint))
(define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace)
(define (get-splash-paint-callback) splash-paint-callback)
(define (set-splash-paint-callback sp)
(set! splash-paint-callback sp)
(refresh-splash))
(define (get-splash-width) (send splash-canvas get-width))
(define (get-splash-height) (send splash-canvas get-height))
(define (set-splash-event-callback cb) (set! splash-event-callback cb))
(define (get-splash-event-callback cb) splash-event-callback)
(define (refresh-splash)
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear))
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (splash-event-callback evt) (void))
(define char-observer void)
(define (set-splash-char-observer proc)
(set! char-observer proc))
(define-struct icon (bm x y))
(define icons null)
(define (add-splash-icon bm x y)
(set! icons (cons (make-icon bm x y) icons))
(define (recompute-bitmap/refresh)
(send splash-cache-dc set-bitmap splash-cache-bitmap)
(call-splash-paint-callback splash-cache-dc)
(send splash-cache-dc set-bitmap #f)
(send splash-canvas on-paint))
(define (start-splash _splash-filename _splash-title width-default)
(set! splash-title _splash-title)
(set! splash-filename _splash-filename)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send splash-frame set-label splash-title)
(let/ec k
(define (no-splash)
(set! splash-bitmap #f)
(set! splash-canvas #f)
(set! splash-eventspace #f)
(k (void)))
(unless splash-filename
(no-splash))
(unless (file-exists? splash-filename)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-filename)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-filename))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-filename)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(send splash-frame center 'both)
(send splash-frame show #t)
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
(cond
[(not (is-a? splash-cache-bitmap bitmap%)) (void)]
[(eq? (current-thread) (eventspace-handler-thread splash-eventspace))
(recompute-bitmap/refresh)]
[else
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
recompute-bitmap/refresh))]))
(define (call-splash-paint-callback dc)
(cond
[(equal? 1 (procedure-arity splash-paint-callback))
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send gauge get-value)
(send gauge get-range)
(get-splash-width)
(get-splash-height))])
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (set-splash-progress-bar? b?)
(send gauge-panel change-children
(λ (l) (if b? (list gauge) '()))))
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear)))
(define (splash-event-callback evt) (void))
(define char-observer void)
(define (set-splash-char-observer proc)
(set! char-observer proc))
(define-struct icon (bm x y))
(define icons null)
(define (add-splash-icon bm x y)
(set! icons (cons (make-icon bm x y) icons))
(refresh-splash))
(define (start-splash splash-draw-spec _splash-title width-default)
(set! splash-title _splash-title)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send splash-frame set-label splash-title)
(let/ec k
(define (no-splash)
(set! splash-bitmap #f)
(set! splash-canvas #f)
(set! splash-eventspace #f)
(k (void)))
(define splash-title "no title")
(define splash-current-width 0)
(define (get-splash-width-preference-name)
(string->symbol (format "plt:~a-splash-max-width" splash-title)))
(define splash-max-width 1)
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(when splash-frame
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width))
(old-load f expected)))
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(if (or (getenv "PLTDRCM")
(getenv "PLTDRDEBUG"))
(parameterize ([current-namespace (make-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))
(values #f #f))])
(cond
[(or (path? splash-draw-spec)
(string? splash-draw-spec))
(unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(set! splash-cache-bitmap (make-object bitmap%
(send splash-bitmap get-width)
(send splash-bitmap get-height)))]
[(and (vector? splash-draw-spec)
(procedure? (vector-ref splash-draw-spec 0))
(number? (vector-ref splash-draw-spec 1))
(number? (vector-ref splash-draw-spec 2)))
(set! splash-paint-callback (vector-ref splash-draw-spec 0))
(send splash-canvas min-width (vector-ref splash-draw-spec 1))
(send splash-canvas min-height (vector-ref splash-draw-spec 2))
(set! splash-cache-bitmap (make-object bitmap%
(vector-ref splash-draw-spec 1)
(vector-ref splash-draw-spec 2)))]
[(not splash-draw-spec)
(no-splash)]
[else
(fprintf (current-error-port)
"WARNING: unknown splash spec: ~s" splash-draw-spec)
(no-splash)])
(current-load
(let ([old-load (current-load)])
(λ (f expected)
(splash-load-handler old-load f expected))))
(when (and make-compilation-manager-load/use-compiled-handler
(refresh-splash)
(send splash-frame center 'both)
(send splash-frame show #t)
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
(define splash-title "no title")
(define splash-current-width 0)
(define (get-splash-width-preference-name)
(string->symbol (format "plt:~a-splash-max-width" splash-title)))
(define splash-max-width 1)
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(when splash-frame
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width)
(unless (member gauge (send gauge-panel get-children))
;; when the gauge is not visible, we'll redraw the canvas
(refresh-splash)))
(old-load f expected)))
(let-values ([(make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(λ (x) (display "2: ") (display x) (newline))))))
(if (or (getenv "PLTDRCM")
(getenv "PLTDRDEBUG"))
(parameterize ([current-namespace (make-base-namespace)])
(values
(dynamic-require 'compiler/cm 'make-compilation-manager-load/use-compiled-handler)
(dynamic-require 'compiler/cm 'manager-trace-handler)))
(values #f #f))])
(define funny-gauge%
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height)
(field
[funny-value 0]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
(current-load
(let ([old-load (current-load)])
(λ (f expected)
(splash-load-handler old-load f expected))))
(when (and make-compilation-manager-load/use-compiled-handler
manager-trace-handler)
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n")
(current-load/use-compiled (make-compilation-manager-load/use-compiled-handler))
(when (or (equal? (getenv "PLTDRCM") "trace")
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(λ (x) (display "2: ") (display x) (newline))))))
[define/public set-range (λ (r) (set! max-value r))]
[define/public set-value
(λ (new-value)
(let* ([before-x
(floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
[after-x
(ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))]
[width (- after-x before-x)])
(send (get-dc) draw-line
(+ before-x 2) 0
(+ width 2) 0)
(send (get-dc) draw-line
(+ before-x 2) (+ (send funny-bitmap get-height) 4)
(+ width 2) (+ (send funny-bitmap get-height) 4))
(send (get-dc) draw-bitmap-section funny-bitmap
(+ 2 before-x) 2
before-x 0
width (send funny-bitmap get-height)))
(set! funny-value new-value))]
(define funny-gauge%
(class canvas%
(inherit get-dc min-width min-height stretchable-width stretchable-height)
(field
[funny-value 0]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
(define/public (get-range) max-value)
(define/public (get-value) funny-value)
[define/public set-range (λ (r) (set! max-value r))]
[define/public set-value
(λ (new-value)
(let* ([before-x
(floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
[after-x
(ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))]
[width (- after-x before-x)])
(send (get-dc) draw-line
(+ before-x 2) 0
(+ width 2) 0)
(send (get-dc) draw-line
(+ before-x 2) (+ (send funny-bitmap get-height) 4)
(+ width 2) (+ (send funny-bitmap get-height) 4))
(send (get-dc) draw-bitmap-section funny-bitmap
(+ 2 before-x) 2
before-x 0
width (send funny-bitmap get-height)))
(set! funny-value new-value))]
[define/override (on-paint)
(let ([dc (get-dc)])
(send dc clear)
(send dc draw-rectangle 0 0
(+ (send funny-bitmap get-width) 4)
(+ (send funny-bitmap get-height) 4))
(send dc draw-bitmap-section funny-bitmap
2 2 0 0
(* (send funny-bitmap get-width) (/ funny-value max-value))
(send funny-bitmap get-height)))]
(super-instantiate ())
(min-width (+ (send funny-bitmap get-width) 4))
(min-height (+ (send funny-bitmap get-height) 4))
(stretchable-width #f)
(stretchable-height #f)))
[define/override (on-paint)
(let ([dc (get-dc)])
(send dc clear)
(send dc draw-rectangle 0 0
(+ (send funny-bitmap get-width) 4)
(+ (send funny-bitmap get-height) 4))
(send dc draw-bitmap-section funny-bitmap
2 2 0 0
(* (send funny-bitmap get-width) (/ funny-value max-value))
(send funny-bitmap get-height)))]
(define (splash-get-preference name default)
(get-preference
name
(λ ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(super-instantiate ())
(min-width (+ (send funny-bitmap get-width) 4))
(min-height (+ (send funny-bitmap get-height) 4))
(stretchable-width #f)
(stretchable-height #f)))
(define (splash-get-preference name default)
(get-preference
name
(λ ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(define (splitup-path f)
(let*-values ([(absf) (if (relative-path? f)
(build-path (current-directory) f)
f)]
[(base name _1) (split-path absf)])
(if base
(let-values ([(base2 name2 _2) (split-path base)])
(if base2
(let-values ([(base3 name3 _2) (split-path base2)])
(build-path name3 name2 name))
(build-path name2 name)))
name)))
(define quit-on-close? #t)
(define splash-frame%
(class frame%
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new)))
(define splash-canvas%
(class canvas%
(inherit get-dc)
(define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (splash-paint-callback (get-dc)))
(define/override (on-event evt) (splash-event-callback evt))
(super-new)))
(define splash-frame
(parameterize ([current-eventspace splash-eventspace])
(instantiate splash-frame% ()
(label splash-title)
(style '(no-resize-border)))))
(send splash-frame set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (make-object splash-canvas% panel))
(define h-panel (make-object horizontal-pane% panel))
(define gauge
(if funny?
(make-object funny-gauge% h-panel)
(make-object gauge% #f splash-max-width h-panel '(horizontal))))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send h-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f))
(define (splitup-path f)
(let*-values ([(absf) (if (relative-path? f)
(build-path (current-directory) f)
f)]
[(base name _1) (split-path absf)])
(if base
(let-values ([(base2 name2 _2) (split-path base)])
(if base2
(let-values ([(base3 name3 _2) (split-path base2)])
(build-path name3 name2 name))
(build-path name2 name)))
name)))
(define quit-on-close? #t)
(define splash-frame%
(class frame%
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new)))
(define splash-canvas%
(class canvas%
(inherit get-client-size get-dc)
(define/override (on-char evt) (char-observer evt))
(define/override (on-paint) (send (get-dc) draw-bitmap splash-cache-bitmap 0 0))
(define/override (on-event evt) (splash-event-callback evt))
(super-new)))
(define splash-frame
(parameterize ([current-eventspace splash-eventspace])
(instantiate splash-frame% ()
(label splash-title)
(style '(no-resize-border)))))
(send splash-frame set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-frame))
(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
(define gauge-panel (make-object horizontal-pane% panel))
(define gauge
(if funny?
(make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width gauge-panel '(horizontal))))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send gauge-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f)