From ff53c99b9822355761a0b0e52d1ce7882bef780e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 7 Dec 1998 02:08:07 +0000 Subject: [PATCH] ... original commit: 361f1c25d8a002bda273ba4592ba120fa0b50fb6 --- collects/framework/splash.ss | 166 +++++++++++++++++++++++++++++++++++ 1 file changed, 166 insertions(+) create mode 100644 collects/framework/splash.ss diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss new file mode 100644 index 00000000..809cac78 --- /dev/null +++ b/collects/framework/splash.ss @@ -0,0 +1,166 @@ +; filename : splash-image-path +; title : title of window + +(lambda (filename title width-default depth-default) + (let/ec k + (let*-values + ([(no-splash) (lambda () (k void void void))] + [(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-path 'setup-file)))] + [(_) + (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-depth-resource) (format "~a-splash-max-depth" title)] + [(splash-max-width) (splash-get-resource splash-width-resource width-default)] + [(splash-max-depth) (splash-get-resource splash-depth-resource depth-default)] + + [(splash-sofar-depth) 0] + [(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] + [(splash-frame%) + (class frame% (title) + (override + [on-close + (lambda () + (when quit-on-close? + (exit)))]) + (sequence (super-init title)))] + [(frame) (parameterize ([current-eventspace (make-eventspace)]) + (make-object splash-frame% title))] + [(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)] + [(_) (unless (send bitmap ok?) + (fprintf (current-error-port) "WARNING: bad bitmap ~s" filename) + (no-splash))] + [(canvas%) + (class canvas% args + (inherit get-dc) + (override + [on-paint + (lambda () + (send (get-dc) draw-bitmap bitmap 0 0))]) + (sequence + (apply super-init args)))] + [(box1) (box 0.)] + [(box2) (box 0.)] + [(c-x-offset) 0] + [(c-y-offset) 0] + + [(logo-canvas) (make-object canvas% frame)] + [(show-messages?) (let ([b (box 0)]) + (if (get-resource "mred" "splashMessages" b) + (not (zero? (unbox b))) + #f))] + [(gauge) (make-object gauge% #f splash-max-width frame)] + [(splash-messages) + (and show-messages? + (cons (make-object message% (format "Welcome to ~a" title) frame) + (let loop ([n (- splash-max-depth 1)]) + (cond + [(zero? n) null] + [else (cons (make-object message% "" frame) + (loop (sub1 n)))]))))] + [(_) (begin + (send frame set-alignment 'left 'center) + (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))] + [(change-splash-message) + (letrec ([change-splash-message + (case-lambda + [(s) (change-splash-message s 0 #f)] + [(s depth clear-after) + (if splash-messages + (unless (null? splash-messages) + (if (< depth splash-max-depth) + (begin '(printf "setting depth ~a (of ~a) to ~s~n" depth splash-max-depth s) + (send (list-ref splash-messages depth) set-label s) + (when (and clear-after + (< (+ depth 1) splash-max-depth)) + (let ([next-message (list-ref splash-messages (+ depth 1))]) + (unless (string=? "" (send next-message get-label)) + '(printf "clearing depth ~a (of ~a)~n" + (+ depth 1) current-splash-max-depth) + (send next-message set-label "")))) + #t) + #f)) + #t)])]) + change-splash-message)] + [(splash-load-handler) + (let ([depth 0]) + (lambda (old-load f) + (let ([finalf (splitup-path f)]) + (set! splash-sofar-depth (max (+ depth 1) splash-sofar-depth)) + (set! splash-current-width (+ splash-current-width 1)) + (when (change-splash-message (format "Loading ~a..." finalf) depth #f) + (when (<= splash-current-width splash-max-width) + (send gauge set-value splash-current-width))) + (set! depth (+ depth 1)) + (begin0 + (old-load f) + (begin (set! depth (- depth 1)) + (change-splash-message (format "Loading ~a...done." finalf) + depth #t))))))] + [(_) (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))) + (unless (= splash-max-width splash-current-width) + (set-resource splash-width-resource splash-current-width)) + (unless (= splash-max-depth splash-sofar-depth) + (set-resource splash-depth-resource splash-sofar-depth)))] + [(close-splash) + (lambda () + (set! quit-on-close? #f) + (send frame show #f))]) + (values + change-splash-message + shutdown-splash + close-splash))))