From d1736765b6f1740976478bfac44a005f1e4eca95 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 18 Aug 2015 14:34:42 -0600
Subject: [PATCH] add `get-gl-client-size` to `canvas%`
GL scaling in a canvas depends on a combination of the `gl-config%`
setting and the platform, so `get-gl-client-size` takes into account
both.
---
gui-doc/scribblings/gui/canvas-class.scrbl | 14 ++++++++++++++
gui-doc/scribblings/gui/canvas-intf.scrbl | 3 ++-
gui-lib/info.rkt | 2 +-
gui-lib/mred/private/mrcanvas.rkt | 2 ++
gui-lib/mred/private/wx/cocoa/canvas.rkt | 9 +++++++++
gui-lib/mred/private/wx/gtk/canvas.rkt | 8 +++++++-
gui-lib/mred/private/wx/win32/window.rkt | 3 +++
7 files changed, 38 insertions(+), 3 deletions(-)
diff --git a/gui-doc/scribblings/gui/canvas-class.scrbl b/gui-doc/scribblings/gui/canvas-class.scrbl
index badaa604..c761e347 100644
--- a/gui-doc/scribblings/gui/canvas-class.scrbl
+++ b/gui-doc/scribblings/gui/canvas-class.scrbl
@@ -100,6 +100,20 @@ The @racket[gl-config] argument determines properties of an OpenGL
}
+@defmethod[(get-gl-client-size) (values dimension-integer? dimension-integer?)]{
+
+Returns the canvas's drawing-area dimensions in OpenGL units for a
+@racket[canvas%] instance with the @racket['gl] style.
+
+The result is the same as @method[canvas<%> get-unscaled-client-size]
+in a canvas without the @racket['gl] style or on Windows and Unix. On
+Mac OS X, the result can be the same as @method[window<%>
+get-client-size] if the @racket[gl-config%] specification provided on
+creation does not specify high-resolution mode.
+
+@history[#:added "1.16]}
+
+
@defmethod[(get-scroll-page [which (or/c 'horizontal 'vertical)])
positive-dimension-integer?]{
diff --git a/gui-doc/scribblings/gui/canvas-intf.scrbl b/gui-doc/scribblings/gui/canvas-intf.scrbl
index 117bd97a..3af58dd0 100644
--- a/gui-doc/scribblings/gui/canvas-intf.scrbl
+++ b/gui-doc/scribblings/gui/canvas-intf.scrbl
@@ -158,7 +158,8 @@ a viewport size for OpenGL drawing in @racket[canvas%] instance with
the @racket['gl] style. On Mac OS X, however, the viewport will match
the scaled size unless the canvas is created with a
@racket[gl-config%] specification that is adjusted to high-resolution
-mode via @method[gl-config% set-hires-mode].
+mode via @method[gl-config% set-hires-mode]. See also
+@xmethod[canvas% get-gl-client-size].
@history[#:added "1.13"]}
diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt
index e64074a2..db8dd6e8 100644
--- a/gui-lib/info.rkt
+++ b/gui-lib/info.rkt
@@ -30,4 +30,4 @@
(define pkg-authors '(mflatt robby))
-(define version "1.15")
+(define version "1.16")
diff --git a/gui-lib/mred/private/mrcanvas.rkt b/gui-lib/mred/private/mrcanvas.rkt
index f397c37f..03f88faf 100644
--- a/gui-lib/mred/private/mrcanvas.rkt
+++ b/gui-lib/mred/private/mrcanvas.rkt
@@ -134,6 +134,8 @@
(if ctx
(send ctx call-as-current thunk)
(fail))))
+ (define/public (get-gl-client-size)
+ (send wx get-gl-client-size))
(define accept-tab-focus
(entry-point
(case-lambda
diff --git a/gui-lib/mred/private/wx/cocoa/canvas.rkt b/gui-lib/mred/private/wx/cocoa/canvas.rkt
index e4503c15..41b3c4f6 100644
--- a/gui-lib/mred/private/wx/cocoa/canvas.rkt
+++ b/gui-lib/mred/private/wx/cocoa/canvas.rkt
@@ -884,6 +884,15 @@
(define cw (->long (NSSize-width cs)))
(define ch (->long (NSSize-height cs)))
(values cw ch))
+
+ (define/public (get-gl-client-size)
+ (if (or (not is-gl?)
+ (tell #:type _BOOL content-cocoa wantsBestResolutionOpenGLSurface))
+ (get-scaled-client-size)
+ (let ([x (box 0)]
+ [y (box 0)])
+ (get-client-size x y)
+ (values (unbox x) (unbox y)))))
(define/override (get-cursor-width-delta)
0)
diff --git a/gui-lib/mred/private/wx/gtk/canvas.rkt b/gui-lib/mred/private/wx/gtk/canvas.rkt
index c9e4ae70..38e1f41b 100644
--- a/gui-lib/mred/private/wx/gtk/canvas.rkt
+++ b/gui-lib/mred/private/wx/gtk/canvas.rkt
@@ -504,7 +504,13 @@
(define wb (box #f))
(define hb (box #f))
(get-client-size wb hb)
- (values (->screen (unbox wb)) (->screen (unbox hb))))
+ (define s (if gtk3?
+ (gtk_widget_get_scale_factor gtk)
+ 1))
+ (values (* s (->screen (unbox wb))) (* s (->screen (unbox hb)))))
+
+ (define/public (get-gl-client-size)
+ (get-scaled-client-size))
(define/override (get-client-gtk) client-gtk)
(define/override (get-container-gtk) container-gtk)
diff --git a/gui-lib/mred/private/wx/win32/window.rkt b/gui-lib/mred/private/wx/win32/window.rkt
index 29f18cc0..38b0dfc4 100644
--- a/gui-lib/mred/private/wx/win32/window.rkt
+++ b/gui-lib/mred/private/wx/win32/window.rkt
@@ -491,6 +491,9 @@
(let ([r (GetClientRect (get-client-hwnd))])
(values (- (RECT-right r) (RECT-left r))
(- (RECT-bottom r) (RECT-top r)))))
+
+ (define/public (get-gl-client-size)
+ (get-scaled-client-size))
(define/public (get-size w h)
(let ([r (GetWindowRect (get-client-hwnd))])