Mac OS X: support Retina mode

Seems to work for Mac OS X 10.9 (Mavericks), at least.

In Retina mode, a drawing unit corresponds to two pixels on
the screen or in a bitmap created by `make-screen-bitmap'.
In particular, a bitmap created by `make-screen-bitmap' is
actually twice as big in each dimension as requested, and the
bitmap is scaled when transferring to other drawing contexts.
When transferring onto the screen, scalings cancel so that the
result looks right.

Adds `get-display-backing-scale` to `racket/gui/base`, and
also `get-backing-scale` to `bitmap%`.

To do: add a way to set the backing scale of a bitmap. That
option will provide a way to give controls higher-resolution
bitmaps as labels.

pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl

@@ -76,6 +76,18 @@ the bitmap is selected into another DC, attached as a button label, etc.).
 
 }
 
+@defmethod[(get-backing-scale)
+           (>/c 0.0)]{
+
+Gets the number of pixels that correspond to a drawing unit for the
+bitmap, either when the bitmap is used as a target for drawing or when
+the bitmap is drawn into another context.
+
+For example, on Mac OS X when the main monitor is in Retina mode,
+@racket[make-screen-bitmap] returns a bitmap whose backing scale is
+@racket[2.0].}
+
+
 @defmethod[(get-depth)
            exact-nonnegative-integer?]{
 

pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-dc-class.scrbl

@@ -90,7 +90,12 @@ If @racket[pre-multiplied?] is true, @racket[just-alpha?] is false,
  are scaled by the corresponding alpha value (i.e., multiplied by the
  alpha value and then divided by 255).
 
-}
+If the bitmap has a backing scale (see @xmethod[bitmap%
+ get-backing-scale]) other than @racket[1.0], the the result of
+ @method[bitmap-dc% get-argb-pixels] is as if the bitmap is drawn to a
+ bitmap with a backing scale of @racket[1.0] and the pixels of the
+ target bitmap are returned.}
+
 
 @defmethod[(get-bitmap)
            (or/c (is-a?/c bitmap%) #f)]{

pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl

@@ -755,8 +755,11 @@ Different kinds of bitmaps can produce different results:
        make-bitmap] uses the same platform-specific drawing operations
        as drawing into a @racket[canvas%] instance. A bitmap produced
        by @racket[make-screen-bitmap] is the same as one produced by
-       @racket[make-platform-bitmap] on Windows or Mac OS X, but it may
-       be sensitive to the X11 server on Unix.
+       @racket[make-platform-bitmap] on Windows or Mac OS X, but it
+       may be sensitive to the X11 server on Unix. On Mac OS X, when
+       the main screen is in Retina mode (at the time that the bitmap
+       is created), the bitmap is also internally scaled so that one
+       drawing unit uses two pixels.
 
        Use @racket[make-screen-bitmap] when drawing to a bitmap as an
        offscreen buffer before transferring an image to the screen, or

pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt

@@ -21,7 +21,16 @@
     (define b&w? #f)
     
     (when _bm
-      (do-set-bitmap _bm #f))
+      (do-set-bitmap _bm #f)
+      ;; Needed if the bitmap has a device scale:
+      (when c (init-cr-matrix c)))
+
+    (define/override (init-cr-matrix cr)
+      (when bm
+        (define s (send bm get-cairo-device-scale))
+        (unless (= s 1)
+          (cairo_scale cr s s)))
+      (super init-cr-matrix cr))
 
     (define/override (ok?) (and c #t))
 

pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt

@@ -504,6 +504,13 @@
         (let ([p (cairo_get_source cr)])
           (cairo_pattern_reference p)
           (cairo_set_source_surface cr (get-cairo-surface) (- x) (- y))
+          (let ([sc (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_matrix_translate m x y)
+                (cairo_pattern_set_matrix (cairo_get_source cr) m))))
           (cairo_new_path cr)
           (cairo_rectangle cr 0 0 w h)
           (cairo_fill cr)
@@ -633,6 +640,10 @@
                 alpha-s))
           (get-empty-surface)))
 
+    (define/public (get-cairo-device-scale) 1.0)
+
+    (define/public (get-backing-scale) (get-cairo-device-scale))
+
     (define/public (get-handle) s)
 
     (define/public (get-argb-pixels x y w h bstr
@@ -912,15 +923,24 @@
 
 (define quartz-bitmap%
   (class bitmap%
-    (init w h [with-alpha? #t])
+    (init w h [with-alpha? #t] [resolution 1.0])
     (super-make-object (make-alternate-bitmap-kind w h))
-
+    
+    (define cocoa-resolution resolution)
+    
+    (define/override (get-cairo-device-scale)
+      cocoa-resolution)
+    
     (define s
       (let ([s (cairo_quartz_surface_create (if with-alpha?
                                                 CAIRO_FORMAT_ARGB32
                                                 CAIRO_FORMAT_RGB24)
-                                            w
-                                            h)])
+                                            (inexact->exact
+                                             (ceiling
+                                              (* cocoa-resolution w)))
+                                            (inexact->exact
+                                             (ceiling
+                                              (* cocoa-resolution h))))])
         ;; initialize bitmap to empty - needed?
         (let ([cr (cairo_create s)])
           (cairo_set_operator cr (if with-alpha?

pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt

@@ -1774,6 +1774,15 @@
                                        (send src get-cairo-surface)
                                        (- a-dest-x a-src-x)
                                        (- a-dest-y a-src-y))
+             (let ([sc (send src 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_matrix_translate m
+                                           (- (- a-dest-x a-src-x))
+                                           (- (- a-dest-y a-src-y)))
+                   (cairo_pattern_set_matrix (cairo_get_source cr) m))))
              (adjust-pattern-filter (cairo_get_source cr))
              (if mask
                  (stamp-pattern mask a-msrc-x a-msrc-y)

pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt

@@ -10,6 +10,7 @@
   ;; bitmap%
   get-cairo-surface
   get-cairo-alpha-surface
+  get-cairo-device-scale
   release-bitmap-storage
   get-bitmap-gl-context
   drop-alpha-s

pkgs/draw-pkgs/draw-lib/racket/draw/unsafe/cairo.rkt

@@ -265,6 +265,10 @@
   #:wrap (allocator cairo_surface_destroy))
 (define-cairo cairo_ps_surface_create (_cfun _path _double* _double* -> _cairo_surface_t)
   #:wrap (allocator cairo_surface_destroy))
+(define-cairo cairo_surface_set_fallback_resolution (_cfun _cairo_surface_t _double* _double* -> _void))
+(define-cairo cairo_surface_get_fallback_resolution (_cfun _cairo_surface_t (x : (_ptr o _double)) (y :  (_ptr o _double))
+                                                           -> _void
+                                                           -> (values x y)))
 
 ;; Stream surfaces
 

pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl

@@ -14,13 +14,26 @@ Normally, drawing is automatically flushed to the screen. Use
 other actions depend on updating the display.}
 
 
+@defproc[(get-display-backing-scale [#:monitor monitor exact-nonnegative-integer? 0])
+                                    (or/c (>/c 0.0) #f)]{
+
+Returns the number of pixels that correspond to one drawing unit on a
+monitor.  The result is normally @racket[1.0], but it is @racket[2.0] on
+Mac OS X in Retina display mode.
+
+On Mac OS X, the result can change at any time.  See also
+@xmethod[top-level-window<%> display-changed].
+
+If @racket[monitor] is not less than the current number of available
+ monitors (which can change at any time), the is @racket[#f]. See also
+ @xmethod[top-level-window<%> display-changed].}
+
+
 @defproc[(get-display-count) exact-positive-integer?]{
 Returns the number of monitors currently active. 
 
 On Windows and Mac OS X, the result can change at any time.
-See also @xmethod[top-level-window<%> display-changed].
-
-}
+See also @xmethod[top-level-window<%> display-changed].}
 
 
 @defproc[(get-display-depth)

pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl

@@ -275,8 +275,13 @@ environment of the result namespace.}
 Creates a bitmap that draws in a way that is the same as drawing to a
 canvas in its default configuration.
 
-See also @secref[#:doc '(lib "scribblings/draw/draw.scrbl") "Portability"].
-}
+In particular, on Mac OS X when the main monitor is in Retina display
+mode, a drawing unit corresponds to two pixels, and the bitmap
+internally contains four times as many pixels as requested by
+@racket[width] and @racket[height]. See also
+@racket[get-display-backing-scale].
+
+See also @secref[#:doc '(lib "scribblings/draw/draw.scrbl") "Portability"].}
 
 
 @defproc[(play-sound [filename path-string?]

pkgs/gui-pkgs/gui-doc/scribblings/gui/top-level-window-intf.scrbl

@@ -197,8 +197,9 @@ Returns @|void-const|.
     Called when the displays configuration changes.
 
     To determine the new monitor configuration, use
-    @racket[get-display-count], @racket[get-display-size], and
-    @racket[get-display-left-top-inset]. 
+    @racket[get-display-count], @racket[get-display-size],
+    @racket[get-display-left-top-inset], and
+    @racket[get-display-backing-scale].
 
     Note that this method may be invoked multiple times for a single
     logical change to the monitors.

pkgs/gui-pkgs/gui-lib/mred/HISTORY.txt

@@ -1,6 +1,10 @@
+Version 5.90.0.9
+Added get-display-backing-scale
+Added get-backing-scale to bitmap%
+
 Version 5.90.0.5
 
-Fix key-event% get-key-release-code to return 'press instead of 'down
+Fixed key-event% get-key-release-code to return 'press instead of 'down
  for a key-down event
 
 ----------------------------------------

pkgs/gui-pkgs/gui-lib/mred/mred-sig.rkt

@@ -82,6 +82,7 @@ get-color-from-user
 get-current-mouse-state
 get-default-shortcut-prefix
 get-directory
+get-display-backing-scale
 get-display-count
 get-display-depth
 get-display-left-top-inset

pkgs/gui-pkgs/gui-lib/mred/private/mred.rkt

@@ -251,6 +251,7 @@
 	   get-display-size
 	   get-display-left-top-inset
 	   get-display-count
+           get-display-backing-scale
 	   get-color-from-user
 	   get-font-from-user
            append-editor-operation-menu-items

pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt

@@ -413,7 +413,7 @@
      (define/public (get-dc) dc)
 
      (define/public (make-compatible-bitmap w h)
-       (make-object quartz-bitmap% w h))
+       (make-screen-bitmap w h))
 
      (define/override (fix-dc [refresh? #t])
        (when (dc . is-a? . dc%)

pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/dc.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require racket/class
+(require "../../syntax.rkt"
+         racket/class
          ffi/unsafe
          ffi/unsafe/objc
          racket/draw/unsafe/cairo
@@ -16,9 +17,11 @@
 
 (provide 
  (protect-out dc%
-              do-backing-flush))
+              do-backing-flush)
+ display-bitmap-resolution
+ make-screen-bitmap)
 
-(import-class NSOpenGLContext)
+(import-class NSOpenGLContext NSScreen)
 (define NSOpenGLCPSwapInterval 222)
 
 (define dc%
@@ -59,7 +62,8 @@
     ;; Use a quartz bitmap so that text looks good:
     (define trans? transparent?)
     (define/override (make-backing-bitmap w h) 
-      (make-object quartz-bitmap% w h trans?))
+      (make-object quartz-bitmap% w h trans? 
+                   (display-bitmap-resolution 0 void)))
     (define/override (can-combine-text? sz) #t)
 
     (define/override (get-backing-size xb yb)
@@ -104,3 +108,23 @@
                  (backing-draw-bm bm cr (unbox w) (unbox h))
                  (cairo_destroy cr))))))
    (tellv ctx restoreGraphicsState)))
+
+(define (display-bitmap-resolution num fail)
+  (let ([r (atomically
+            (with-autorelease
+             (let ([s (if (zero? num)
+                          (tell NSScreen mainScreen)
+                          (let ([screens (tell NSScreen screens)])
+                            (if (num . < . (tell #:type _NSUInteger screens count))
+                                (tell screens objectAtIndex: #:type _NSUInteger num)
+                                #f)))])
+               (and s
+                    (tell #:type _CGFloat s backingScaleFactor)))))])
+    (cond
+     [(not r) (fail)]
+     [(zero? r) 1.0]
+     [else r])))
+
+(define/top (make-screen-bitmap [exact-positive-integer? w]
+                                [exact-positive-integer? h])
+  (make-object quartz-bitmap% w h #t (display-bitmap-resolution 0 void)))

pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/platform.rkt

@@ -62,6 +62,7 @@
    display-size
    display-origin
    display-count
+   display-bitmap-resolution
    flush-display
    get-current-mouse-state
    fill-private-color

pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt

@@ -53,6 +53,7 @@
   get-highlight-background-color
   get-highlight-text-color
   check-for-break)
+ display-bitmap-resolution
  make-screen-bitmap
  make-gl-bitmap
  show-print-setup
@@ -157,10 +158,6 @@
 (define (id-to-menu-item id) id)
 (define (can-show-print-setup?) #t)
 
-(define/top (make-screen-bitmap [exact-positive-integer? w]
-                                [exact-positive-integer? h])
-  (make-object quartz-bitmap% w h))
-
 (define/top (make-gl-bitmap [exact-positive-integer? w]
                             [exact-positive-integer? h]
                             [gl-config% c])

pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt

@@ -214,6 +214,12 @@
 	  (cairo_translate cr dx dy))
         (cairo_pattern_reference s)
         (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))))
         (cairo_new_path cr)
         (cairo_rectangle cr 0 0 w h)
         (cairo_fill cr)

pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/frame.rkt

@@ -22,6 +22,7 @@
               display-origin
               display-size
 	      display-count
+              display-bitmap-resolution
               location->window
               get-current-mouse-state))
 
@@ -558,6 +559,13 @@
 (define (display-count)
   (gdk_screen_get_n_monitors (gdk_screen_get_default)))
 
+(define (display-bitmap-resolution num fail)
+  (if (zero? num)
+      1.0
+      (if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default)))
+          1.0
+          (fail))))
+
 (define (location->window x y)
   (for/or ([f (in-hash-keys all-frames)])
     (let ([fx (send f get-x)]

pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/platform.rkt

@@ -63,6 +63,7 @@
    display-size
    display-origin
    display-count
+   display-bitmap-resolution
    flush-display
    get-current-mouse-state
    fill-private-color

pkgs/gui-pkgs/gui-lib/mred/private/wx/gtk/procs.rkt

@@ -48,6 +48,7 @@
  show-print-setup
  display-origin
  display-size
+ display-bitmap-resolution
  flush-display
  location->window
  make-screen-bitmap

pkgs/gui-pkgs/gui-lib/mred/private/wx/platform.rkt

@@ -49,6 +49,7 @@
                 display-size
                 display-origin
 		display-count
+                display-bitmap-resolution
                 flush-display
                 get-current-mouse-state
                 fill-private-color

pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/frame.rkt

@@ -22,7 +22,8 @@
  (protect-out frame%
               display-size
               display-origin
-	      display-count))
+	      display-count
+              display-bitmap-resolution))
 
 (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL))
 (define-user32 GetActiveWindow (_wfun -> _HWND))
@@ -152,7 +153,18 @@
     (set-box! yb 0)]))
 
 (define (display-count)
-  (length (get-all-screen-rects)))
+  (let ([pos 0])
+    (EnumDisplayMonitors #f #f (lambda (mon dc r ptr)
+                                 (set! pos (add1 pos))
+                                 #t)
+                         #f)
+    pos))
+
+(define (display-bitmap-resolution num fail)
+  (if (or (zero? num)
+          (num . < . (display-count)))
+      1.0
+      (fail)))
 
 (define mouse-frame #f)
 

pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/platform.rkt

@@ -63,6 +63,7 @@
    display-size
    display-origin
    display-count
+   display-bitmap-resolution
    flush-display
    get-current-mouse-state
    fill-private-color

pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/procs.rkt

@@ -53,6 +53,7 @@
  file-creator-and-type
  display-origin
  display-size
+ display-bitmap-resolution
  make-screen-bitmap
  make-gl-bitmap
  special-control-key

pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt

@@ -18,6 +18,7 @@
 	   get-display-size
 	   get-display-left-top-inset
 	   get-display-count
+	   get-display-backing-scale
 	   (protect-out make-top-container%
 			make-top-level-window-glue%
 			wx-frame%
@@ -59,6 +60,12 @@
     (lambda ()
       (wx:display-count)))
 
+  (define get-display-backing-scale
+    (lambda (#:monitor [monitor 0])
+      (unless (exact-nonnegative-integer? monitor)
+	(raise-argument-error 'get-display-backing-scale "exact-nonnegative-integer?" monitor))
+      (wx:display-bitmap-resolution monitor (lambda () #f))))
+
   (define-values (left-margin top-margin init-top-x init-top-y)
     (let-values ([(x y) (get-display-left-top-inset #f)]
 		 [(x2 y2) (get-display-left-top-inset #t)])

racket/src/mac/osx_appl.rkt

@@ -15,8 +15,17 @@
 	   racket/file
            racket/path)
 
+  (define (try . l)
+    (or (ormap (lambda (f)
+		 (and (file-exists? f)
+		      f))
+	       l)
+	(car (reverse l))))
+
   (define rez-path (or (getenv "REZ")
-		       "/Developer/Tools/Rez"))
+		       (find-executable-path "Rez")
+		       (try "/Applications/Xcode.app/Contents/Developer/Tools/Rez"
+			    "/Developer/Tools/Rez")))
 
   (define for-3m? (getenv "BUILDING_3M"))
 
@@ -101,7 +110,9 @@
 	   (assoc-pair "CFBundleVersion"
 		       ,(version))
 	   (assoc-pair "CFBundleShortVersionString"
-		       ,(version))))
+		       ,(version))
+	   (assoc-pair "NSPrincipalClass" "NSApplicationMain")
+	   (assoc-pair "NSHighResolutionCapable" (true))))
 
     (create-app (build-path (current-directory) (if for-3m? 'up 'same))
                 (string-append "GRacket" suffix)