From 85e4fed31f5d8a50c9508c7c89c3cb49edaa2466 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Sep 2010 07:43:17 -0600 Subject: [PATCH] use canvas-compatible bitmap for prefetch --- collects/slideshow/core.rkt | 2 +- collects/slideshow/private/utils.rkt | 16 +------------ collects/slideshow/viewer.rkt | 36 +++++++++++++++------------- 3 files changed, 21 insertions(+), 33 deletions(-) diff --git a/collects/slideshow/core.rkt b/collects/slideshow/core.rkt index 709b0fee14..c343e583a7 100644 --- a/collects/slideshow/core.rkt +++ b/collects/slideshow/core.rkt @@ -1019,7 +1019,7 @@ (+ x-space (* xs w))) (>= (send scroll-bm get-height) (+ y-space (* ys h)))) - (set! scroll-bm (make-bitmap + (set! scroll-bm (make-screen-bitmap (inexact->exact (ceiling (+ x-space (* xs w)))) (inexact->exact (ceiling (+ y-space (* ys h)))))) (if (send scroll-bm ok?) diff --git a/collects/slideshow/private/utils.rkt b/collects/slideshow/private/utils.rkt index 83a6da2e77..412ac6cbd5 100644 --- a/collects/slideshow/private/utils.rkt +++ b/collects/slideshow/private/utils.rkt @@ -3,23 +3,9 @@ (require mred mzlib/class) - (provide make-bitmap - define-accessor + (provide define-accessor define/provide-struct) - ;; If bitmap creation fails, try an explicit GC. - ;; (This loop should be built into GRacket, but it wasn't - ;; at the time this code was written.) - (define (make-bitmap w h) - (let loop ([n 0]) - (let ([bm (make-object bitmap% w h)]) - (if (or (= n 4) - (send bm ok?)) - bm - (begin - (collect-garbage) - (loop (add1 n))))))) - (define-syntax define-accessor (syntax-rules () [(_ margin get-margin) diff --git a/collects/slideshow/viewer.rkt b/collects/slideshow/viewer.rkt index a87f215252..23c010f49f 100644 --- a/collects/slideshow/viewer.rkt +++ b/collects/slideshow/viewer.rkt @@ -607,7 +607,7 @@ (define c% (class canvas% - (inherit get-dc get-client-size) + (inherit get-dc get-client-size make-bitmap) (define clicking #f) (define clicking-hit? #f) @@ -621,7 +621,7 @@ (send (get-dc) draw-bitmap bm 0 0))] [else (send dc clear) - (paint-slide dc)]))) + (paint-slide this dc)]))) (inherit get-top-level-window) (define/override (on-event e) @@ -777,7 +777,7 @@ [(equal? prefetched-page current-page) (paint-prefetch offscreen)] [else - (paint-slide offscreen)]) + (paint-slide this offscreen)]) (let ([bm (send offscreen get-bitmap)]) (send (get-dc) draw-bitmap bm 0 0))] [(equal? prefetched-page current-page) @@ -785,7 +785,7 @@ [else (let ([dc (get-dc)]) (send dc clear) - (paint-slide dc))]))) + (paint-slide this dc))]))) (super-new [style '(no-autoclear)]))) (define two-c% @@ -827,7 +827,7 @@ (send dc set-brush b)))]) (send dc set-scale 1 1))] [else - (paint-slide dc current-page 2/3 1 cw ch cw ch #f) + (paint-slide this dc current-page 2/3 1 cw ch cw ch #f) (let ([pen (send dc get-pen)] [brush (send dc get-brush)]) (send dc set-pen "black" 1 'solid) @@ -847,7 +847,8 @@ (send dc set-origin (* cw 2/3) (* ch 1/6)) (when (< (add1 current-page) slide-count) (send dc draw-rectangle (* cw 2/3) 0 (* cw 1/3) ch) - (paint-slide dc + (paint-slide this + dc (+ current-page 1) 1/3 1/2 cw ch cw ch @@ -884,11 +885,11 @@ (define paint-slide (case-lambda - [(dc) (paint-slide dc current-page)] - [(dc page) + [(canvas dc) (paint-slide canvas dc current-page)] + [(canvas dc page) (let-values ([(cw ch) (send dc get-size)]) - (paint-slide dc page 1 1 cw ch config:use-screen-w config:use-screen-h #t))] - [(dc page extra-scale-x extra-scale-y cw ch usw ush to-main?) + (paint-slide canvas dc page 1 1 cw ch config:use-screen-w config:use-screen-h #t))] + [(canvas dc page extra-scale-x extra-scale-y cw ch usw ush to-main?) (let* ([slide (if (sliderec? page) page (talk-list-ref page))] @@ -949,7 +950,7 @@ ;; prefetched-click-regions : list (define prefetched-click-regions null) - (define (prefetch-slide n) + (define (prefetch-slide canvas n) (set! prefetched-page #f) (unless prefetch-dc @@ -960,7 +961,7 @@ (= config:use-screen-w (send prefetch-bitmap get-width)) (= config:use-screen-h (send prefetch-bitmap get-height))) (send prefetch-dc set-bitmap #f) - (set! prefetch-bitmap (make-bitmap config:use-screen-w config:use-screen-h)) + (set! prefetch-bitmap (send canvas make-bitmap config:use-screen-w config:use-screen-h)) (when (send prefetch-bitmap ok?) (send prefetch-dc set-bitmap prefetch-bitmap))) @@ -970,7 +971,7 @@ [old-adjust adjust-cursor]) (set! click-regions null) (set! adjust-cursor void) - (paint-slide prefetch-dc n) + (paint-slide canvas prefetch-dc n) (set! prefetched-click-regions click-regions) (set! click-regions old-click-regions) (set! adjust-cursor old-adjust)) @@ -979,7 +980,7 @@ (send f-both is-shown?)) (send c-both paint-prefetched)))) - (define (schedule-slide-prefetch n delay-msec) + (define (schedule-slide-prefetch canvas n delay-msec) (cancel-prefetch) (when (and config:use-prefetch? (not (equal? n prefetched-page))) @@ -990,9 +991,9 @@ (when (unbox b) (if (pair? current-transitions) ;; try again to wait for transition to end - (schedule-slide-prefetch n delay-msec) + (schedule-slide-prefetch canvas n delay-msec) ;; Build next slide... - (prefetch-slide n))))])))) + (prefetch-slide canvas n))))])))) (define (cancel-prefetch) @@ -1013,7 +1014,8 @@ (when (and c-both (send f-both is-shown?)) (send c-both redraw)) (when (< current-page (- slide-count 1)) - (schedule-slide-prefetch (+ current-page 1) + (schedule-slide-prefetch c + (+ current-page 1) (if immediate-prefetch? 50 500)))))