suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

use canvas-compatible bitmap for prefetch

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-16 07:43:17 -06:00
parent 42b8534a4a
commit 85e4fed31f
3 changed files with 21 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/slideshow/core.rkt
View File

@ -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?)

16
collects/slideshow/private/utils.rkt
View File

@ -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)

36
collects/slideshow/viewer.rkt
View File

@ -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)))))