splash.rkt
1 #lang racket/base 2 3 (require racket/class 4 racket/file 5 racket/gui/base 6 racket/contract 7 (for-syntax racket/base)) 8 9 (provide 10 (contract-out 11 [get-splash-bitmap (-> (or/c #f (is-a?/c bitmap%)))] 12 [set-splash-bitmap (-> (is-a?/c bitmap%) void?)] 13 [get-splash-canvas (-> (is-a?/c canvas%))] 14 [get-splash-eventspace (-> eventspace?)] 15 [get-splash-paint-callback (-> procedure?)] 16 [set-splash-paint-callback (-> (or/c (-> (is-a?/c dc<%>) 17 exact-nonnegative-integer? 18 exact-nonnegative-integer? 19 exact-nonnegative-integer? 20 exact-nonnegative-integer? 21 any) 22 (-> (is-a?/c dc<%>) 23 any)) 24 void?)] 25 [start-splash 26 (->* ((or/c path-string? 27 (is-a?/c bitmap%) 28 (vector/c (or/c (-> (is-a?/c dc<%>) void?) 29 (-> (is-a?/c dc<%>) 30 exact-nonnegative-integer? 31 exact-nonnegative-integer? 32 exact-nonnegative-integer? 33 exact-nonnegative-integer? 34 any)) 35 exact-nonnegative-integer? 36 exact-nonnegative-integer?)) 37 string? 38 exact-nonnegative-integer?) 39 (#:allow-funny? 40 boolean? 41 #:frame-icon 42 (or/c #f 43 (is-a?/c bitmap%) 44 (cons/c (is-a?/c bitmap%) 45 (is-a?/c bitmap%)))) 46 void?)] 47 48 [shutdown-splash (-> void?)] 49 [close-splash (-> void?)] 50 [add-splash-icon (-> (is-a?/c bitmap%) real? real? void?)] 51 [set-splash-progress-bar?! (-> boolean? void?)] 52 [set-splash-char-observer (-> procedure? void?)] 53 [set-splash-event-callback (-> procedure? void?)] 54 [get-splash-event-callback (-> procedure?)] 55 [set-refresh-splash-on-gauge-change?! (-> procedure? void?)] 56 [get-splash-width (-> exact-nonnegative-integer?)] 57 [get-splash-height (-> exact-nonnegative-integer?)] 58 [refresh-splash (-> void?)])) 59 60 (define splash-bitmap #f) 61 (define splash-cache-bitmap #f) 62 (define splash-cache-dc (make-object bitmap-dc%)) 63 (define splash-eventspace (make-eventspace)) 64 65 (define (on-splash-eventspace/proc t) 66 (parameterize ([current-eventspace splash-eventspace]) 67 (queue-callback t))) 68 (define-syntax-rule 69 (on-splash-eventspace e ...) 70 (on-splash-eventspace/proc (λ () e ...))) 71 72 (define (on-splash-eventspace/ret/proc t) 73 (define c (make-channel)) 74 (parameterize ([current-eventspace splash-eventspace]) 75 (queue-callback 76 (λ () 77 (channel-put c (t))))) 78 (channel-get c)) 79 80 (define-syntax (on-splash-eventspace/ret stx) 81 (syntax-case stx () 82 [(_ e ...) 83 (with-syntax ([line (syntax-line stx)]) 84 #'(on-splash-eventspace/ret/proc (λ () e ...)) 85 #; 86 #'(begin 87 (printf "starting ~a\n" line) 88 (begin0 89 (on-splash-eventspace/ret/proc (λ () (with-handlers ((exn:fail? (λ (x) 90 (printf "~a\n" (exn-message x)) 91 (for ([x (in-list (continuation-mark-set->context 92 (exn-continuation-marks x)))]) 93 (printf " ~s\n" x)) 94 (void)))) 95 e ...))) 96 (printf "finishing ~a\n" line))))])) 97 98 (define (get-splash-bitmap) (on-splash-eventspace/ret splash-bitmap)) 99 (define (set-splash-bitmap bm) 100 (on-splash-eventspace 101 (set! splash-bitmap bm) 102 (send splash-canvas on-paint))) 103 (define (get-splash-canvas) splash-canvas) 104 (define (get-splash-eventspace) splash-eventspace) 105 106 (define (get-splash-paint-callback) (on-splash-eventspace/ret splash-paint-callback)) 107 (define (set-splash-paint-callback sp) 108 (on-splash-eventspace 109 (set! splash-paint-callback sp) 110 (refresh-splash))) 111 112 (define (get-splash-width) (on-splash-eventspace/ret (send splash-canvas get-width))) 113 (define (get-splash-height) (on-splash-eventspace/ret (send splash-canvas get-height))) 114 115 (define (set-splash-event-callback cb) (on-splash-eventspace (set! splash-event-callback cb))) 116 (define (get-splash-event-callback) (on-splash-eventspace/ret splash-event-callback)) 117 118 (define (refresh-splash-on-gauge-change? start range) #f) 119 (define (set-refresh-splash-on-gauge-change?! f) 120 (on-splash-eventspace (set! refresh-splash-on-gauge-change? f))) 121 122 (define (refresh-splash) 123 124 (define (recompute-bitmap/refresh) 125 (send splash-cache-dc set-bitmap splash-cache-bitmap) 126 (call-splash-paint-callback splash-cache-dc) 127 (send splash-cache-dc set-bitmap #f) 128 (send splash-canvas on-paint)) 129 130 (define (call-splash-paint-callback dc) 131 (cond 132 [(equal? 1 (procedure-arity splash-paint-callback)) 133 (splash-paint-callback dc)] 134 [else 135 (splash-paint-callback dc 136 (send (get-gauge) get-value) 137 (send (get-gauge) get-range) 138 (send splash-canvas get-width) 139 (send splash-canvas get-height))]) 140 (for-each (λ (icon) 141 (send dc draw-bitmap 142 (icon-bm icon) 143 (icon-x icon) 144 (icon-y icon) 145 'solid 146 (make-object color% "black") 147 (send (icon-bm icon) get-loaded-mask))) 148 icons)) 149 150 (cond 151 [(not (is-a? splash-cache-bitmap bitmap%)) (void)] 152 [(eq? (current-thread) (eventspace-handler-thread splash-eventspace)) 153 (recompute-bitmap/refresh)] 154 [else 155 (parameterize ([current-eventspace splash-eventspace]) 156 (queue-callback 157 recompute-bitmap/refresh))]) 158 159 (void)) 160 161 (define (set-splash-progress-bar?! b?) 162 (on-splash-eventspace/ret 163 (get-gauge) ;; force the gauge to be created 164 (send gauge-panel change-children 165 (λ (l) (if b? (list (get-gauge)) '()))))) 166 167 ;; the function bound to the variable should only be called on the splash-eventspace main thread 168 (define (splash-paint-callback dc) 169 (if splash-bitmap 170 (begin 171 (send dc clear) 172 (send dc draw-bitmap splash-bitmap 0 0)) 173 (send dc clear))) 174 175 (define (splash-event-callback evt) (void)) 176 177 (define char-observer void) 178 (define (set-splash-char-observer proc) 179 (set! char-observer proc)) 180 181 (define-struct icon (bm x y)) 182 (define icons null) 183 (define (add-splash-icon bm x y) 184 (on-splash-eventspace 185 (set! icons (cons (make-icon bm x y) icons)) 186 (refresh-splash))) 187 188 (define (start-splash splash-draw-spec _splash-title width-default 189 #:allow-funny? [allow-funny? #f] 190 #:frame-icon [frame-icon #f]) 191 (unless allow-funny? (set! funny? #f)) 192 (set! splash-title _splash-title) 193 (set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default))) 194 195 (on-splash-eventspace/ret 196 (let/ec k 197 (define (no-splash) 198 (set! splash-bitmap #f) 199 (k (void))) 200 (send (get-gauge) set-range splash-max-width) 201 (send splash-tlw set-label splash-title) 202 203 (when frame-icon 204 (if (pair? frame-icon) 205 (let ([small (car frame-icon)] 206 [large (cdr frame-icon)]) 207 (send splash-tlw set-icon small (send small get-loaded-mask) 'small) 208 (send splash-tlw set-icon large (send large get-loaded-mask) 'large)) 209 (send splash-tlw set-icon frame-icon (send frame-icon get-loaded-mask) 'both))) 210 211 (cond 212 [(or (path-string? splash-draw-spec) 213 (is-a? splash-draw-spec bitmap%)) 214 (cond 215 [(path-string? splash-draw-spec) 216 (unless (file-exists? splash-draw-spec) 217 (eprintf "WARNING: bitmap path ~s not found\n" splash-draw-spec) 218 (no-splash)) 219 220 (set! splash-bitmap (read-bitmap splash-draw-spec #:try-@2x? #t))] 221 [else 222 (set! splash-bitmap splash-draw-spec)]) 223 224 (unless (send splash-bitmap ok?) 225 (no-splash)) 226 227 (send splash-canvas min-width (send splash-bitmap get-width)) 228 (send splash-canvas min-height (send splash-bitmap get-height)) 229 (set! splash-cache-bitmap (make-screen-bitmap 230 (send splash-bitmap get-width) 231 (send splash-bitmap get-height)))] 232 [(and (vector? splash-draw-spec) 233 (procedure? (vector-ref splash-draw-spec 0)) 234 (number? (vector-ref splash-draw-spec 1)) 235 (number? (vector-ref splash-draw-spec 2))) 236 (set! splash-paint-callback (vector-ref splash-draw-spec 0)) 237 (send splash-canvas min-width (vector-ref splash-draw-spec 1)) 238 (send splash-canvas min-height (vector-ref splash-draw-spec 2)) 239 (set! splash-cache-bitmap (make-screen-bitmap 240 (vector-ref splash-draw-spec 1) 241 (vector-ref splash-draw-spec 2)))]) 242 243 (send splash-tlw reflow-container) 244 245 (refresh-splash) 246 247 (send splash-tlw center 'both) 248 (send splash-tlw show-without-yield) 249 (sync (system-idle-evt)) ; try to wait for dialog to be shown 250 (flush-display) (yield) (sleep) 251 (flush-display) (yield) (sleep)))) 252 253 (define splash-title "no title") 254 255 (define splash-current-width 0) 256 257 (define (get-splash-width-preference-name) 258 (string->symbol (format "plt:~a-splash-max-width" splash-title))) 259 (define splash-max-width 1) 260 261 (define (close-splash) 262 (unless (= splash-max-width splash-current-width) 263 (splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width))) 264 (on-splash-eventspace/ret (set! quit-on-close? #f)) 265 (when splash-tlw 266 (on-splash-eventspace 267 (send splash-tlw show #f)))) 268 269 (define (shutdown-splash) 270 (set! splash-load-handler (λ (old-load f expected) (old-load f expected)))) 271 272 (define funny? 273 (let ([date (seconds->date (let ([ssec (getenv "PLTDREASTERSECONDS")]) 274 (if ssec 275 (string->number ssec) 276 (current-seconds))))]) 277 (and (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) 278 (collection-path "icons") 279 #t) 280 (= (date-day date) 25) 281 (= (date-month date) 12)))) 282 283 (define (splash-load-handler old-load f expected) 284 (set! splash-current-width (+ splash-current-width 1)) 285 (when (<= splash-current-width splash-max-width) 286 (let ([splash-save-width splash-current-width]) 287 (on-splash-eventspace 288 (send (get-gauge) set-value splash-save-width) 289 (when (or (not (member (get-gauge) (send gauge-panel get-children))) 290 ;; when the gauge is not visible, we'll redraw the canvas regardless 291 (refresh-splash-on-gauge-change? splash-save-width splash-max-width)) 292 (refresh-splash))))) 293 (old-load f expected)) 294 295 (let ([make-compilation-manager-load/use-compiled-handler 296 (if (or (getenv "PLTDRCM") 297 (getenv "PLTDRDEBUG")) 298 (parameterize ([current-namespace (make-base-namespace)]) 299 (dynamic-require 'compiler/cm 300 'make-compilation-manager-load/use-compiled-handler)) 301 #f)]) 302 303 (current-load 304 (let ([old-load (current-load)]) 305 (λ (f expected) 306 (splash-load-handler old-load f expected)))) 307 308 (when make-compilation-manager-load/use-compiled-handler 309 (printf "PLTDRCM/PLTDRDEBUG: reinstalling CM load handler after setting splash load handler\n") 310 (current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)))) 311 312 (define funny-gauge% 313 (class canvas% 314 (inherit get-dc min-width min-height stretchable-width stretchable-height) 315 (field 316 [funny-value 0] 317 [funny-bitmap 318 (make-object bitmap% (collection-file-path "touch.bmp" "icons"))] 319 [max-value 1]) 320 321 (define/public (get-range) max-value) 322 (define/public (get-value) funny-value) 323 324 [define/public set-range (λ (r) (set! max-value r))] 325 [define/public set-value 326 (λ (new-value) 327 (let* ([before-x 328 (floor (* (send funny-bitmap get-width) (/ funny-value max-value)))] 329 [after-x 330 (ceiling (* (send funny-bitmap get-width) (/ new-value max-value)))] 331 [width (- after-x before-x)]) 332 (send (get-dc) draw-line 333 (+ before-x 2) 0 334 (+ width 2) 0) 335 (send (get-dc) draw-line 336 (+ before-x 2) (+ (send funny-bitmap get-height) 4) 337 (+ width 2) (+ (send funny-bitmap get-height) 4)) 338 (send (get-dc) draw-bitmap-section funny-bitmap 339 (+ 2 before-x) 2 340 before-x 0 341 width (send funny-bitmap get-height))) 342 (set! funny-value new-value))] 343 344 [define/override (on-paint) 345 (let ([dc (get-dc)]) 346 (send dc clear) 347 (send dc draw-rectangle 0 0 348 (+ (send funny-bitmap get-width) 4) 349 (+ (send funny-bitmap get-height) 4)) 350 (send dc draw-bitmap-section funny-bitmap 351 2 2 0 0 352 (* (send funny-bitmap get-width) (/ funny-value max-value)) 353 (send funny-bitmap get-height)))] 354 355 (super-instantiate ()) 356 (min-width (+ (send funny-bitmap get-width) 4)) 357 (min-height (+ (send funny-bitmap get-height) 4)) 358 (stretchable-width #f) 359 (stretchable-height #f))) 360 361 (define (splash-get-preference name default) 362 (get-preference 363 name 364 (λ () default) 365 #:timeout-lock-there (λ (path) default))) 366 (define (splash-set-preference name value) 367 (with-handlers ((exn:fail? 368 (λ (exn) 369 (log-warning (format "splash pref save: ~a" (exn-message exn)))))) 370 (put-preferences (list name) (list value) void))) 371 372 ;; only modified (or read) on the splash eventspace handler thread 373 (define quit-on-close? #t) 374 375 (define splash-tlw% 376 (class dialog% 377 (define/augment (on-close) 378 (when quit-on-close? 379 (exit))) 380 (super-new [style '(close-button)]))) 381 382 (define splash-canvas% 383 (class canvas% 384 (inherit get-client-size get-dc) 385 (define/override (on-char evt) (char-observer evt)) 386 (define/override (on-paint) (when splash-cache-bitmap (send (get-dc) draw-bitmap splash-cache-bitmap 0 0))) 387 (define/override (on-event evt) (splash-event-callback evt)) 388 (super-new))) 389 390 (define splash-tlw 391 (parameterize ([current-eventspace splash-eventspace]) 392 (new splash-tlw% 393 (label splash-title)))) 394 395 (define panel (on-splash-eventspace/ret (make-object vertical-pane% splash-tlw))) 396 (define splash-canvas (on-splash-eventspace/ret (new splash-canvas% [parent panel] [style '(no-autoclear)]))) 397 (define gauge-panel (on-splash-eventspace/ret (make-object horizontal-pane% panel))) 398 399 ;; only called on the splash eventspace main thread 400 (define get-gauge 401 (let ([gauge #f]) 402 (λ () 403 (unless (eq? (current-thread) (eventspace-handler-thread splash-eventspace)) 404 (error 'get-gauge "called from the wrong thread")) 405 (unless gauge 406 (set! gauge 407 (if funny? 408 (make-object funny-gauge% gauge-panel) 409 (make-object gauge% #f splash-max-width gauge-panel '(horizontal))))) 410 gauge))) 411 (on-splash-eventspace/ret 412 (send splash-tlw set-alignment 'center 'center) 413 (send panel stretchable-width #f) 414 (send panel stretchable-height #f) 415 (send gauge-panel set-alignment 'center 'top) 416 (send splash-canvas focus) 417 (send splash-canvas stretchable-width #f) 418 (send splash-canvas stretchable-height #f))