From 4f86f1de6232250d7f5debbd5cae02674d2ac106 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Jan 2014 07:14:41 -0700 Subject: [PATCH] racket/gui cocoa: preserve resolution of bitmaps as control labels This change is mainly for Retina display mode. --- .../gui-lib/mred/private/wx/cocoa/image.rkt | 21 ++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt index 5b759a979e..3af93c205d 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/image.rkt @@ -65,9 +65,23 @@ (free info)) (define (bitmap->image bm) - (let* ([w (send bm get-width)] - [h (send bm get-height)] - [str (make-bytes (* w h 4) 255)]) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define s (send bm get-backing-scale)) + (cond + [(= s 1) (bitmap->image* bm w h w h)] + [else + (define (scale v) (inexact->exact (ceiling (* s v)))) + (define sw (scale w)) + (define sh (scale h)) + (define bm2 (make-bitmap sw sh)) + (define dc (send bm2 make-dc)) + (send dc set-scale s s) + (send dc draw-bitmap bm 0 0) + (bitmap->image* bm2 sw sh w h)])) + +(define (bitmap->image* bm w h iw ih) + (let ([str (make-bytes (* w h 4) 255)]) (send bm get-argb-pixels 0 0 w h str #f) (let ([mask (send bm get-loaded-mask)]) (when mask @@ -108,6 +122,7 @@ (make-NSRect (make-NSPoint 0 0) size) image) (tellv i unlockFocus) + (tellv i setSize: #:type _NSSize (make-NSSize iw ih)) i)))))) (define (image->bitmap i)