diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 20189949..abed8448 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -1,198 +1,198 @@ -; filename : splash-image-path -; title : title of window -; width-default : number (module splash mzscheme (require (lib "class100.ss") (lib "class.ss") (lib "mred.ss" "mred")) - - (provide splash) - - (define (splash filename title width-default) + + (provide get-splash-bitmap get-splash-canvas get-splash-eventspace get-dropped-files + start-splash shutdown-splash close-splash) + + (define splash-filename #f) + (define splash-bitmap #f) + (define splash-eventspace (make-eventspace)) + (define dropped-files null) + + (define (get-splash-bitmap) splash-bitmap) + (define (get-splash-canvas) splash-canvas) + (define (get-splash-eventspace) splash-eventspace) + (define (get-dropped-files) dropped-files) + + (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-resource (get-splash-width-resource) width-default))) + (send gauge set-range splash-max-width) + (send splash-frame set-label splash-title) (let/ec k - (letrec-values - ([(splash-eventspace) (make-eventspace)] - [(no-splash) (lambda () (k #f #f splash-eventspace void void void))] - [(funny?) (let ([date (seconds->date (current-seconds))]) - (and (= (date-day date) 25) - (= (date-month date) 12)))] - - [(funny-bitmap) - (make-object bitmap% - (build-path (collection-path "icons") "touch.bmp"))] - [(funny-value) 0] - [(funny-gauge%) - (class100 canvas% (_max-value parent) - (inherit get-dc min-width min-height stretchable-width stretchable-height) - (private-field - [max-value _max-value]) - (public - [set-value - (lambda (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 funny-value) - max-value)))]) - (send (get-dc) draw-line - (+ before-x 2) 0 - (+ after-x 2) 0) - (send (get-dc) draw-line - (+ before-x 2) (+ (send funny-bitmap get-height) 4) - (+ after-x 2) (+ (send funny-bitmap get-height) 4)) - (send (get-dc) draw-bitmap-section bitmap - (+ 2 before-x) 2 - before-x 0 - after-x (send funny-bitmap get-height))) - (set! funny-value new-value))]) - (override - [on-paint - (lambda () - (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))))]) - (sequence - (super-init parent) - (min-width (+ (send funny-bitmap get-width) 4)) - (min-height (+ (send funny-bitmap get-height) 4)) - (stretchable-width #f) - (stretchable-height #f)))] - - [(splash-get-resource) - (lambda (name default) - (let ([b (box 0)]) - (if (get-resource "mred" name b #f) - (unbox b) - default)))] - [(set-resource) - (lambda (name value) - (write-resource "mred" name value (find-graphical-system-path 'setup-file)))] - [(_1) - (begin - (unless filename - (no-splash)) - (unless (file-exists? filename) - (fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" filename) - (no-splash)))] - - [(splash-width-resource) (format "~a-splash-max-width" title)] - [(splash-max-width) (max 1 (splash-get-resource splash-width-resource width-default))] - - [(splash-current-width) 0] - - [(splitup-path) - (lambda (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)))] - - [(quit-on-close?) #t] - [(dropped-files) null] - [(get-dropped-files) (lambda () dropped-files)] - [(splash-frame%) - (class100 frame% (title) - (override - [on-drop-file - (lambda (filename) - (set! dropped-files (cons filename dropped-files)))] - [on-close - (lambda () - (when quit-on-close? - (exit)))]) - (sequence (super-init title)))] - [(frame) (parameterize ([current-eventspace splash-eventspace]) - (make-object splash-frame% title))] - [(_0) (send frame accept-drop-files #t)] - [(bitmap-flag) - (let ([len (string-length filename)]) - (if (<= len 4) - 'guess - (let ([suffix (substring filename (- len 4) len)]) - (cond - [(string-ci=? ".xpm" suffix) 'xpm] - [(string-ci=? ".xbm" suffix) 'xbm] - [(string-ci=? ".gif" suffix) 'gif] - [(string-ci=? "pict" suffix) 'pict] - [else 'xpm]))))] - [(bitmap) (make-object bitmap% filename bitmap-flag)] - [(_2) (unless (send bitmap ok?) - (fprintf (current-error-port) "WARNING: bad bitmap ~s~n" filename) - (no-splash))] - [(splash-canvas%) - (class100 canvas% args - (inherit get-dc) - (override - [on-paint - (lambda () - (send (get-dc) draw-bitmap bitmap 0 0))]) - (sequence - (apply super-init args)))] - [(panel) (make-object vertical-pane% frame)] - [(logo-canvas) (make-object splash-canvas% panel)] - [(h-panel) (make-object horizontal-pane% panel)] - [(gauge) - (if funny? - (make-object funny-gauge% splash-max-width h-panel) - (make-object gauge% #f splash-max-width h-panel '(horizontal)))] - [(spacer) (make-object grow-box-spacer-pane% h-panel)] - [(_3) (begin - (send frame set-alignment 'center 'center) - (send panel stretchable-width #f) - (send panel stretchable-height #f) - (send h-panel set-alignment 'center 'top) - (send logo-canvas min-width (send bitmap get-width)) - (send logo-canvas min-height (send bitmap get-height)) - (send logo-canvas stretchable-width #f) - (send logo-canvas stretchable-height #f) - (send frame center 'both) - (send frame show #t) - (flush-display) (yield) (sleep) - (flush-display) (yield) (sleep))] - [(inc-splash) - (lambda () - (set! splash-current-width (+ splash-current-width 1)) - (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width)))] - [(splash-load-handler) - (lambda (old-load f) - (let ([finalf (splitup-path f)]) - (inc-splash) - (old-load f)))] - [(_4) (current-load - (let ([old-load (current-load)]) - (lambda (f) - (splash-load-handler old-load f))))] - [(shutdown-splash) - (lambda () - (set! splash-load-handler (lambda (old-load f) (old-load f))))] - [(close-splash) - (lambda () - (inc-splash) - (unless (= splash-max-width splash-current-width) - (set-resource splash-width-resource (max 1 splash-current-width))) - (set! quit-on-close? #f) - (send frame show #f))]) - (values - bitmap - logo-canvas - splash-eventspace - get-dropped-files - shutdown-splash - close-splash))))) + (define (no-splash) + (set! splash-bitmap #f) + (set! splash-canvas #f) + (set! splash-eventspace #f) + (set! dropped-files null) + (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))) + + (define splash-title "no title") + + (define splash-current-width 0) + + (define (get-splash-width-resource) (format "~a-splash-max-width" splash-title)) + (define splash-max-width 1) + + (define (close-splash) + (unless (= splash-max-width splash-current-width) + (set-resource (get-splash-width-resource) (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 (lambda (old-load f) (old-load f)))) + + (define funny? + '(let ([date (seconds->date (current-seconds))]) + (and (= (date-day date) 25) + (= (date-month date) 12)))) + + (define (splash-load-handler old-load f) + (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))) + + (current-load + (let ([old-load (current-load)]) + (lambda (f) + (splash-load-handler old-load f)))) + + (define funny-gauge% + (class100 canvas% (parent) + (inherit get-dc min-width min-height stretchable-width stretchable-height) + (private-field + [funny-value 0] + [funny-bitmap (make-object bitmap% + (build-path (collection-path "icons") "touch.bmp"))] + [max-value 1]) + (public + [set-range (lambda (r) (set! max-value r))] + [set-value + (lambda (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))]) + (override + [on-paint + (lambda () + (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))))]) + (sequence + (super-init parent) + (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-resource name default) + (let ([b (box 0)]) + (if (get-resource "mred" name b #f) + (unbox b) + default))) + (define (set-resource name value) + (write-resource "mred" name value (find-graphical-system-path 'setup-file))) + + (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% + (override on-drop-file on-close) + (define (on-drop-file filename) + (set! dropped-files (cons filename dropped-files))) + (define (on-close) + (when quit-on-close? + (exit))) + (super-instantiate ()))) + + (define splash-canvas% + (class100 canvas% args + (inherit get-dc) + (override + [on-paint + (lambda () + (if splash-bitmap + (send (get-dc) draw-bitmap splash-bitmap 0 0) + (send (get-dc) clear)))]) + (sequence + (apply super-init args)))) + + (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) + (send splash-frame accept-drop-files #t) + + (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 stretchable-width #f) + (send splash-canvas stretchable-height #f))