419 lines
16 KiB
Racket
419 lines
16 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/file
|
|
racket/gui/base
|
|
racket/contract
|
|
(for-syntax racket/base))
|
|
|
|
(provide
|
|
(contract-out
|
|
[get-splash-bitmap (-> (or/c #f (is-a?/c bitmap%)))]
|
|
[set-splash-bitmap (-> (is-a?/c bitmap%) void?)]
|
|
[get-splash-canvas (-> (is-a?/c canvas%))]
|
|
[get-splash-eventspace (-> eventspace?)]
|
|
[get-splash-paint-callback (-> procedure?)]
|
|
[set-splash-paint-callback (-> (or/c (-> (is-a?/c dc<%>)
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
any)
|
|
(-> (is-a?/c dc<%>)
|
|
any))
|
|
void?)]
|
|
[start-splash
|
|
(->* ((or/c path-string?
|
|
(is-a?/c bitmap%)
|
|
(vector/c (or/c (-> (is-a?/c dc<%>) void?)
|
|
(-> (is-a?/c dc<%>)
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?
|
|
any))
|
|
exact-nonnegative-integer?
|
|
exact-nonnegative-integer?))
|
|
string?
|
|
exact-nonnegative-integer?)
|
|
(#:allow-funny?
|
|
boolean?
|
|
#:frame-icon
|
|
(or/c #f
|
|
(is-a?/c bitmap%)
|
|
(cons/c (is-a?/c bitmap%)
|
|
(is-a?/c bitmap%))))
|
|
void?)]
|
|
|
|
[shutdown-splash (-> void?)]
|
|
[close-splash (-> void?)]
|
|
[add-splash-icon (-> (is-a?/c bitmap%) real? real? void?)]
|
|
[set-splash-progress-bar?! (-> boolean? void?)]
|
|
[set-splash-char-observer (-> procedure? void?)]
|
|
[set-splash-event-callback (-> procedure? void?)]
|
|
[get-splash-event-callback (-> procedure?)]
|
|
[set-refresh-splash-on-gauge-change?! (-> procedure? void?)]
|
|
[get-splash-width (-> exact-nonnegative-integer?)]
|
|
[get-splash-height (-> exact-nonnegative-integer?)]
|
|
[refresh-splash (-> void?)]))
|
|
|
|
(define splash-bitmap #f)
|
|
(define splash-cache-bitmap #f)
|
|
(define splash-cache-dc (make-object bitmap-dc%))
|
|
(define splash-eventspace (make-eventspace))
|
|
|
|
(define (on-splash-eventspace/proc t)
|
|
(parameterize ([current-eventspace splash-eventspace])
|
|
(queue-callback t)))
|
|
(define-syntax-rule
|
|
(on-splash-eventspace e ...)
|
|
(on-splash-eventspace/proc (λ () e ...)))
|
|
|
|
(define (on-splash-eventspace/ret/proc t)
|
|
(define c (make-channel))
|
|
(parameterize ([current-eventspace splash-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(channel-put c (t)))))
|
|
(channel-get c))
|
|
|
|
(define-syntax (on-splash-eventspace/ret stx)
|
|
(syntax-case stx ()
|
|
[(_ e ...)
|
|
(with-syntax ([line (syntax-line stx)])
|
|
#'(on-splash-eventspace/ret/proc (λ () e ...))
|
|
#;
|
|
#'(begin
|
|
(printf "starting ~a\n" line)
|
|
(begin0
|
|
(on-splash-eventspace/ret/proc (λ () (with-handlers ((exn:fail? (λ (x)
|
|
(printf "~a\n" (exn-message x))
|
|
(for ([x (in-list (continuation-mark-set->context
|
|
(exn-continuation-marks x)))])
|
|
(printf " ~s\n" x))
|
|
(void))))
|
|
e ...)))
|
|
(printf "finishing ~a\n" line))))]))
|
|
|
|
(define (get-splash-bitmap) (on-splash-eventspace/ret splash-bitmap))
|
|
(define (set-splash-bitmap bm)
|
|
(on-splash-eventspace
|
|
(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) (on-splash-eventspace/ret splash-paint-callback))
|
|
(define (set-splash-paint-callback sp)
|
|
(on-splash-eventspace
|
|
(set! splash-paint-callback sp)
|
|
(refresh-splash)))
|
|
|
|
(define (get-splash-width) (on-splash-eventspace/ret (send splash-canvas get-width)))
|
|
(define (get-splash-height) (on-splash-eventspace/ret (send splash-canvas get-height)))
|
|
|
|
(define (set-splash-event-callback cb) (on-splash-eventspace (set! splash-event-callback cb)))
|
|
(define (get-splash-event-callback) (on-splash-eventspace/ret splash-event-callback))
|
|
|
|
(define (refresh-splash-on-gauge-change? start range) #f)
|
|
(define (set-refresh-splash-on-gauge-change?! f)
|
|
(on-splash-eventspace (set! refresh-splash-on-gauge-change? f)))
|
|
|
|
(define (refresh-splash)
|
|
|
|
(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 (call-splash-paint-callback dc)
|
|
(cond
|
|
[(equal? 1 (procedure-arity splash-paint-callback))
|
|
(splash-paint-callback dc)]
|
|
[else
|
|
(splash-paint-callback dc
|
|
(send (get-gauge) get-value)
|
|
(send (get-gauge) get-range)
|
|
(send splash-canvas get-width)
|
|
(send splash-canvas get-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))
|
|
|
|
(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))])
|
|
|
|
(void))
|
|
|
|
(define (set-splash-progress-bar?! b?)
|
|
(on-splash-eventspace/ret
|
|
(get-gauge) ;; force the gauge to be created
|
|
(send gauge-panel change-children
|
|
(λ (l) (if b? (list (get-gauge)) '())))))
|
|
|
|
;; the function bound to the variable should only be called on the splash-eventspace main thread
|
|
(define (splash-paint-callback dc)
|
|
(if splash-bitmap
|
|
(begin
|
|
(send dc clear)
|
|
(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)
|
|
(on-splash-eventspace
|
|
(set! icons (cons (make-icon bm x y) icons))
|
|
(refresh-splash)))
|
|
|
|
(define (start-splash splash-draw-spec _splash-title width-default
|
|
#:allow-funny? [allow-funny? #f]
|
|
#:frame-icon [frame-icon #f])
|
|
(unless allow-funny? (set! funny? #f))
|
|
(set! splash-title _splash-title)
|
|
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
|
|
|
|
(on-splash-eventspace/ret
|
|
(let/ec k
|
|
(define (no-splash)
|
|
(set! splash-bitmap #f)
|
|
(k (void)))
|
|
(send (get-gauge) set-range splash-max-width)
|
|
(send splash-tlw set-label splash-title)
|
|
|
|
(when frame-icon
|
|
(if (pair? frame-icon)
|
|
(let ([small (car frame-icon)]
|
|
[large (cdr frame-icon)])
|
|
(send splash-tlw set-icon small (send small get-loaded-mask) 'small)
|
|
(send splash-tlw set-icon large (send large get-loaded-mask) 'large))
|
|
(send splash-tlw set-icon frame-icon (send frame-icon get-loaded-mask) 'both)))
|
|
|
|
(cond
|
|
[(or (path-string? splash-draw-spec)
|
|
(is-a? splash-draw-spec bitmap%))
|
|
(cond
|
|
[(path-string? splash-draw-spec)
|
|
(unless (file-exists? splash-draw-spec)
|
|
(eprintf "WARNING: bitmap path ~s not found\n" splash-draw-spec)
|
|
(no-splash))
|
|
|
|
(set! splash-bitmap (read-bitmap splash-draw-spec #:try-@2x? #t))]
|
|
[else
|
|
(set! splash-bitmap splash-draw-spec)])
|
|
|
|
(unless (send splash-bitmap ok?)
|
|
(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-screen-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-screen-bitmap
|
|
(vector-ref splash-draw-spec 1)
|
|
(vector-ref splash-draw-spec 2)))])
|
|
|
|
(send splash-tlw reflow-container)
|
|
|
|
(refresh-splash)
|
|
|
|
(send splash-tlw center 'both)
|
|
(send splash-tlw show-without-yield)
|
|
(sync (system-idle-evt)) ; try to wait for dialog to be shown
|
|
(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)))
|
|
(on-splash-eventspace/ret (set! quit-on-close? #f))
|
|
(when splash-tlw
|
|
(on-splash-eventspace
|
|
(send splash-tlw show #f))))
|
|
|
|
(define (shutdown-splash)
|
|
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
|
|
|
|
(define funny?
|
|
(let ([date (seconds->date (let ([ssec (getenv "PLTDREASTERSECONDS")])
|
|
(if ssec
|
|
(string->number ssec)
|
|
(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)
|
|
(set! splash-current-width (+ splash-current-width 1))
|
|
(when (<= splash-current-width splash-max-width)
|
|
(let ([splash-save-width splash-current-width])
|
|
(on-splash-eventspace
|
|
(send (get-gauge) set-value splash-save-width)
|
|
(when (or (not (member (get-gauge) (send gauge-panel get-children)))
|
|
;; when the gauge is not visible, we'll redraw the canvas regardless
|
|
(refresh-splash-on-gauge-change? splash-save-width splash-max-width))
|
|
(refresh-splash)))))
|
|
(old-load f expected))
|
|
|
|
(let ([make-compilation-manager-load/use-compiled-handler
|
|
(if (or (getenv "PLTDRCM")
|
|
(getenv "PLTDRDEBUG"))
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(dynamic-require 'compiler/cm
|
|
'make-compilation-manager-load/use-compiled-handler))
|
|
#f)])
|
|
|
|
(current-load
|
|
(let ([old-load (current-load)])
|
|
(λ (f expected)
|
|
(splash-load-handler old-load f expected))))
|
|
|
|
(when make-compilation-manager-load/use-compiled-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))))
|
|
|
|
(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% (collection-file-path "touch.bmp" "icons"))]
|
|
[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 (splash-get-preference name default)
|
|
(get-preference
|
|
name
|
|
(λ () default)
|
|
#:timeout-lock-there (λ (path) default)))
|
|
(define (splash-set-preference name value)
|
|
(with-handlers ((exn:fail?
|
|
(λ (exn)
|
|
(log-warning (format "splash pref save: ~a" (exn-message exn))))))
|
|
(put-preferences (list name) (list value) void)))
|
|
|
|
;; only modified (or read) on the splash eventspace handler thread
|
|
(define quit-on-close? #t)
|
|
|
|
(define splash-tlw%
|
|
(class dialog%
|
|
(define/augment (on-close)
|
|
(when quit-on-close?
|
|
(exit)))
|
|
(super-new [style '(close-button)])))
|
|
|
|
(define splash-canvas%
|
|
(class canvas%
|
|
(inherit get-client-size get-dc)
|
|
(define/override (on-char evt) (char-observer evt))
|
|
(define/override (on-paint) (when splash-cache-bitmap (send (get-dc) draw-bitmap splash-cache-bitmap 0 0)))
|
|
(define/override (on-event evt) (splash-event-callback evt))
|
|
(super-new)))
|
|
|
|
(define splash-tlw
|
|
(parameterize ([current-eventspace splash-eventspace])
|
|
(new splash-tlw%
|
|
(label splash-title))))
|
|
|
|
(define panel (on-splash-eventspace/ret (make-object vertical-pane% splash-tlw)))
|
|
(define splash-canvas (on-splash-eventspace/ret (new splash-canvas% [parent panel] [style '(no-autoclear)])))
|
|
(define gauge-panel (on-splash-eventspace/ret (make-object horizontal-pane% panel)))
|
|
|
|
;; only called on the splash eventspace main thread
|
|
(define get-gauge
|
|
(let ([gauge #f])
|
|
(λ ()
|
|
(unless (eq? (current-thread) (eventspace-handler-thread splash-eventspace))
|
|
(error 'get-gauge "called from the wrong thread"))
|
|
(unless gauge
|
|
(set! gauge
|
|
(if funny?
|
|
(make-object funny-gauge% gauge-panel)
|
|
(make-object gauge% #f splash-max-width gauge-panel '(horizontal)))))
|
|
gauge)))
|
|
(on-splash-eventspace/ret
|
|
(send splash-tlw set-alignment 'center 'center)
|
|
(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))
|