racket/gui win32: fix handling of @2x bitmaps

Closes PR 14310

original commit: 8a9a592c3ccc508f8547db5db918d008a611d385
This commit is contained in:
Matthew Flatt 2014-01-22 20:03:24 -07:00
parent c3c380f16d
commit dd997cb2dc
2 changed files with 28 additions and 1 deletions

View File

@ -56,6 +56,12 @@
(let ([p (cairo_get_source cr)])
(cairo_pattern_reference p)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(let ([sc (send bm get-cairo-device-scale)])
(unless (= sc 1)
(let ([m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)])
(cairo_matrix_init_translate m 0 0)
(cairo_matrix_scale m sc sc)
(cairo_pattern_set_matrix (cairo_get_source cr) m))))
(if mask-p
(cairo_mask cr mask-p)
(begin

View File

@ -359,11 +359,13 @@
(define return-bmp
(make-object bitmap2% (icons-path "return.xbm") 'xbm))
(define bb-bmp
(make-object bitmap2% (icons-path "bb.gif") 'gif))
(read-bitmap (icons-path "bomb-32x32.png") #:try-@2x? #t))
(define mred-bmp
(make-object bitmap2% (icons-path "mred.xbm") 'xbm))
(define nruter-bmp
(make-object bitmap2% (local-path "nruter.xbm") 'xbm))
(define gc-bmp
(read-bitmap (icons-path "recycle.png") #:try-@2x? #t))
(define (add-label-direction label-h? l)
(if (not label-h?)
@ -2488,6 +2490,25 @@
"Warp Pointer" edp
(lambda (b e)
(send selector warp-pointer 5 5)))
(let* ([w (send gc-bmp get-width)]
[h (send gc-bmp get-height)]
[c (new (class canvas%
(super-new)
(define/override (on-event e)
(when (send e button-down?)
(collect-garbage))))
[parent edp]
[stretchable-width #f]
[stretchable-height #f]
[vert-margin 2]
[horiz-margin 2]
[min-width w]
[min-height h])])
(register-collecting-blit c
0 0 (send gc-bmp get-width) (send gc-bmp get-height)
gc-bmp (make-bitmap w h #f)))
(define (choose-next radios)
(let loop ([l radios])