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

slideshow: always clip drawing to slide area

Browse Source
This commit is contained in:
Matthew Flatt 2013-09-27 14:45:13 -04:00
parent c3eae40f4c
commit fbf8bacb95
1 changed files with 30 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/slideshow-pkgs/slideshow-lib/slideshow/viewer.rkt
View File

@ -835,7 +835,7 @@
(define/private (paint-prefetch dc)
(let-values ([(cw ch) (get-client-size)])
(paint-letterbox dc cw ch config:use-screen-w config:use-screen-h)
(paint-letterbox dc cw ch config:use-screen-w config:use-screen-h #f)
(let ([dx (floor (/ (- cw config:use-screen-w) 2))]
[dy (floor (/ (- ch config:use-screen-h) 2))])
(send dc draw-bitmap prefetch-bitmap dx dy)
@ -1039,8 +1039,8 @@
(define/public (redraw) (unless printing? (on-paint)))
(super-new)))
(define (paint-letterbox dc cw ch usw ush)
(when (or (< usw cw)
(define (paint-letterbox dc cw ch usw ush clip?)
(and (or (< usw cw)
(< ush ch))
(let ([b (send dc get-brush)]
[p (send dc get-pen)])
@ -1055,7 +1055,14 @@
(send dc draw-rectangle 0 0 cw half)
(send dc draw-rectangle 0 (- ch half) cw half)))
(send dc set-brush b)
(send dc set-pen p))))
(send dc set-pen p)
(and clip?
(begin0
(send dc get-clipping-region)
(send dc set-clipping-rect
(/ (- cw usw) 2)
(/ (- ch ush) 2)
usw ush))))))
(define paint-slide
(case-lambda
@ -1078,7 +1085,7 @@
[sy (/ ush config:screen-h)]
[mx (/ (- cw usw) 2)]
[my (/ (- ch ush) 2)])
(paint-letterbox dc cw ch usw ush)
(define clip-rgn (paint-letterbox dc cw ch usw ush #t))
(when config:smoothing?
(send dc set-smoothing 'aligned))
@ -1111,7 +1118,10 @@
(- cw w 5 (* sx (sinset-r ins)) (/ (- cw usw) 2))
(- ch h 5 (* sy (sinset-b ins)) (/ (- ch ush) 2))))
(send dc set-text-foreground c)
(send dc set-font f))))]))
(send dc set-font f)))
(when clip-rgn
(send dc set-clipping-region clip-rgn)))]))
;; prefetched-page : (union #f number)
(define prefetched-page #f)