From 5b7bf69a13b9b5883a496443b329227d4239bfca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 Aug 2015 14:03:18 -0600 Subject: [PATCH] HiDPI support on Unix (Gtk2) Support GUI scaling in much the same way as on Windows, where the OS setting ("org.gnome.desktop.interface.scaling-factor" times "...text-scaling-factor") determines the scale that is used for both graphics and GUI sizing. As I understand it, a complete solution requires porting to Gtk3. With Gtk2, the graphical part of a widget doesn't scale. Text and image labels should scale correctly, though. --- .../scribblings/gui/global-draw-funcs.scrbl | 4 +- gui-doc/scribblings/gui/libs.scrbl | 1 + gui-doc/scribblings/gui/win-overview.scrbl | 7 +-- gui-lib/info.rkt | 2 +- .../mred/private/wx/common/canvas-mixin.rkt | 2 +- gui-lib/mred/private/wx/gtk/button.rkt | 5 +- gui-lib/mred/private/wx/gtk/canvas.rkt | 13 +++-- gui-lib/mred/private/wx/gtk/client-window.rkt | 8 +-- gui-lib/mred/private/wx/gtk/dc.rkt | 13 ++--- gui-lib/mred/private/wx/gtk/frame.rkt | 43 ++++++++-------- gui-lib/mred/private/wx/gtk/gsettings.rkt | 41 ++++++++++++++++ gui-lib/mred/private/wx/gtk/item.rkt | 15 +++++- gui-lib/mred/private/wx/gtk/menu.rkt | 4 +- gui-lib/mred/private/wx/gtk/message.rkt | 4 +- gui-lib/mred/private/wx/gtk/panel.rkt | 4 +- gui-lib/mred/private/wx/gtk/pixbuf.rkt | 42 +++++++++++----- gui-lib/mred/private/wx/gtk/radio-box.rkt | 2 +- gui-lib/mred/private/wx/gtk/resolution.rkt | 21 ++++++++ gui-lib/mred/private/wx/gtk/types.rkt | 4 ++ gui-lib/mred/private/wx/gtk/utils.rkt | 34 ++++++++++++- gui-lib/mred/private/wx/gtk/window.rkt | 49 ++++++++++--------- 21 files changed, 228 insertions(+), 90 deletions(-) create mode 100644 gui-lib/mred/private/wx/gtk/gsettings.rkt create mode 100644 gui-lib/mred/private/wx/gtk/resolution.rkt diff --git a/gui-doc/scribblings/gui/global-draw-funcs.scrbl b/gui-doc/scribblings/gui/global-draw-funcs.scrbl index 4e458d30..089898e3 100644 --- a/gui-doc/scribblings/gui/global-draw-funcs.scrbl +++ b/gui-doc/scribblings/gui/global-draw-funcs.scrbl @@ -19,11 +19,11 @@ other actions depend on updating the display.} 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, and on Windows it can be a value +on Mac OS X in Retina display mode, and on Windows or Unix it can be a value such as @racket[1.25], @racket[1.5], or @racket[2.0] when the operating-system scale for text is changed. See also @secref["display-resolution"]. -On Mac OS X, the result can change at any time. See also +On Mac OS X or Unix, 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 diff --git a/gui-doc/scribblings/gui/libs.scrbl b/gui-doc/scribblings/gui/libs.scrbl index 6ce9a911..f75a28ae 100644 --- a/gui-doc/scribblings/gui/libs.scrbl +++ b/gui-doc/scribblings/gui/libs.scrbl @@ -14,6 +14,7 @@ system libraries must be installed for @racketmodname[racket/gui/base]: @item{@filepath{libgdk-x11-2.0[.0]}} @item{@filepath{libgdk_pixbuf-2.0[.0]}} @item{@filepath{libgtk-x11-2.0[.0]}} + @item{@filepath{libgio-2.0[.0]} --- optional, for detecting interface scaling} @item{@filepath{libGL} --- optional, for OpenGL support} @item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support} ] diff --git a/gui-doc/scribblings/gui/win-overview.scrbl b/gui-doc/scribblings/gui/win-overview.scrbl index 9ca42f85..69fdb7a4 100644 --- a/gui-doc/scribblings/gui/win-overview.scrbl +++ b/gui-doc/scribblings/gui/win-overview.scrbl @@ -1012,7 +1012,7 @@ drawing units are used consistently for window sizes, child window positions, and canvas drawing. A ``point'' for font sizing is equivalent to a drawing unit. -On Windows, screen sizes are described to users in terms of pixels, +On Windows and Unix, screen sizes are described to users in terms of pixels, while a scale can be selected independently by the user to apply to text and other items. Typical text scales are 125%, 150%, and 200%. The @racketmodname[racket/gui] library uses this scale for all @@ -1024,7 +1024,4 @@ reported size of a window to be different than a size to which a window has just been set. A ``point'' for font sizing is equivalent to @racket[(/ 96 72)] drawing units. -On Unix, the @racketmodname[racket/gui] library always uses the -drawing units of the X11 server, and it uses a backing scale of -@math{1.0} for screen and canvas-compatible bitmaps. A ``point'' for -font sizing is equivalent to @racket[(/ 96 72)] drawing units. +@history[#:changed "1.14" @elem{Added support for scaling on Unix.}] diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt index ea3c0b61..6e229835 100644 --- a/gui-lib/info.rkt +++ b/gui-lib/info.rkt @@ -30,4 +30,4 @@ (define pkg-authors '(mflatt robby)) -(define version "1.13") +(define version "1.14") diff --git a/gui-lib/mred/private/wx/common/canvas-mixin.rkt b/gui-lib/mred/private/wx/common/canvas-mixin.rkt index d604988c..e6c2eb04 100644 --- a/gui-lib/mred/private/wx/common/canvas-mixin.rkt +++ b/gui-lib/mred/private/wx/common/canvas-mixin.rkt @@ -203,7 +203,7 @@ (= (send on get-width) w) (= (send on get-height) h)) on - (let ([bm (make-object bitmap% w h)]) + (let ([bm (make-object bitmap% w h #:backing-scale (send on get-backing-scale))]) (let ([dc (make-object bitmap-dc% on)]) (send dc draw-bitmap-section on 0 0 on-x on-y w h) (send dc set-bitmap #f) diff --git a/gui-lib/mred/private/wx/gtk/button.rkt b/gui-lib/mred/private/wx/gtk/button.rkt index 957f90db..090b4ea0 100644 --- a/gui-lib/mred/private/wx/gtk/button.rkt +++ b/gui-lib/mred/private/wx/gtk/button.rkt @@ -66,7 +66,8 @@ [else (let ([pixbuf (bitmap->pixbuf (if (pair? label) (car label) - label))]) + label) + (->screen 1.0))]) (atomically (let ([gtk (if (pair? label) (as-gtk-allocation (gtk_new_with_mnemonic (cadr label))) @@ -125,7 +126,7 @@ (gtk_button_set_label gtk (mnemonic-string s)) (when the-font (install-control-font (get-label-gtk) the-font))] [else - (let ([pixbuf (bitmap->pixbuf s)]) + (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))]) (atomically (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)]) (release-pixbuf pixbuf) diff --git a/gui-lib/mred/private/wx/gtk/canvas.rkt b/gui-lib/mred/private/wx/gtk/canvas.rkt index 3d4a0fa6..3f0dadc2 100644 --- a/gui-lib/mred/private/wx/gtk/canvas.rkt +++ b/gui-lib/mred/private/wx/gtk/canvas.rkt @@ -798,10 +798,13 @@ (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y) (let ([on (fix-bitmap-size on w h on-x on-y)] [off (fix-bitmap-size off w h off-x off-y)]) - (let ([on-pixbuf (bitmap->pixbuf on)] - [off-pixbuf (bitmap->pixbuf off)]) + (let ([on-pixbuf (bitmap->pixbuf on (->screen 1.0))] + [off-pixbuf (bitmap->pixbuf off (->screen 1.0))]) (atomically - (set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))) + (set! reg-blits (cons (register-one-blit (->screen x) (->screen y) + (->screen w) (->screen h) + on-pixbuf off-pixbuf) + reg-blits)))))) (define/public (unregister-collecting-blits) (atomically @@ -827,9 +830,9 @@ (gtk_widget_size_request container-gtk req) (gtk_widget_set_size_request container-gtk (max (GtkRequisition-width req) - (+ x w)) + (->screen (+ x w))) (max (GtkRequisition-height req) - (+ y h)))) + (->screen (+ y h))))) (super set-child-size child-gtk x y w h)) (define/override (reset-dc-for-autoscroll) diff --git a/gui-lib/mred/private/wx/gtk/client-window.rkt b/gui-lib/mred/private/wx/gtk/client-window.rkt index 2f5b569c..05b411b2 100644 --- a/gui-lib/mred/private/wx/gtk/client-window.rkt +++ b/gui-lib/mred/private/wx/gtk/client-window.rkt @@ -19,10 +19,10 @@ (let ([wx (gtk->wx gtk)]) (when wx (send wx save-client-size - (GtkAllocation-x a) - (GtkAllocation-y a) - (GtkAllocation-width a) - (GtkAllocation-height a)))) + (->normal (GtkAllocation-x a)) + (->normal (GtkAllocation-y a)) + (->normal (GtkAllocation-width a)) + (->normal (GtkAllocation-height a))))) #t)) (define (client-size-mixin %) diff --git a/gui-lib/mred/private/wx/gtk/dc.rkt b/gui-lib/mred/private/wx/gtk/dc.rkt index 6b42b5be..ec339160 100644 --- a/gui-lib/mred/private/wx/gtk/dc.rkt +++ b/gui-lib/mred/private/wx/gtk/dc.rkt @@ -45,11 +45,11 @@ (define x11-bitmap% (class bitmap% (init w h gdk-win) - (super-make-object (make-alternate-bitmap-kind w h 1.0)) + (super-make-object (make-alternate-bitmap-kind w h (->screen 1.0))) (define pixmap (gdk_pixmap_new gdk-win - (min (max 1 w) 32000) - (min (max 1 h) 32000) + (min (max 1 (->screen w)) 32000) + (min (max 1 (->screen h)) 32000) (if gdk-win -1 (GdkVisual-rec-depth @@ -60,8 +60,8 @@ (gdk_x11_drawable_get_xid pixmap) (gdk_x11_visual_get_xvisual (gdk_drawable_get_visual pixmap)) - w - h)) + (->screen w) + (->screen h))) ;; initialize bitmap to white: (let ([cr (cairo_create s)]) @@ -172,5 +172,6 @@ [h (box 0)]) (send canvas get-client-size w h) (let ([cr (gdk_cairo_create win)]) - (backing-draw-bm bm cr (unbox w) (unbox h)) + (cairo_scale cr (->screen 1.0) (->screen 1.0)) + (backing-draw-bm bm cr (unbox w) (unbox h) 0 0 (->screen 1.0)) (cairo_destroy cr)))))) diff --git a/gui-lib/mred/private/wx/gtk/frame.rkt b/gui-lib/mred/private/wx/gtk/frame.rkt index 38ff0c6a..94ebcc14 100644 --- a/gui-lib/mred/private/wx/gtk/frame.rkt +++ b/gui-lib/mred/private/wx/gtk/frame.rkt @@ -15,6 +15,7 @@ "widget.rkt" "cursor.rkt" "pixbuf.rkt" + "resolution.rkt" "../common/queue.rkt") (provide @@ -101,10 +102,10 @@ (let ([wx (gtk->wx gtk)]) (when wx (send wx remember-size - (GdkEventConfigure-x a) - (GdkEventConfigure-y a) - (GdkEventConfigure-width a) - (GdkEventConfigure-height a)))) + (->normal (GdkEventConfigure-x a)) + (->normal (GdkEventConfigure-y a)) + (->normal (GdkEventConfigure-width a)) + (->normal (GdkEventConfigure-height a))))) #f)) (define-cstruct _GdkEventWindowState ([type _int] @@ -227,8 +228,8 @@ ;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group) (define/override (set-child-size child-gtk x y w h) - (gtk_fixed_move panel-gtk child-gtk x y) - (gtk_widget_set_size_request child-gtk w h)) + (gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y)) + (gtk_widget_set_size_request child-gtk (->screen w) (->screen h))) (define/public (on-close) #t) @@ -253,13 +254,13 @@ (define saved-enforcements (vector 0 0 -1 -1)) (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) - (define (to-max v) (if (= v -1) #x3FFFFF v)) + (define (to-max v) (if (= v -1) #x3FFFFF (->screen v))) (set! saved-enforcements (vector min-x min-y max-x max-y)) (gtk_window_set_geometry_hints gtk gtk - (make-GdkGeometry min-x min-y + (make-GdkGeometry (->screen min-x) (->screen min-y) (to-max max-x) (to-max max-y) 0 0 - inc-x inc-y + (->screen inc-x) (->screen inc-y) 0.0 0.0 0) (bitwise-ior GDK_HINT_MIN_SIZE @@ -307,12 +308,12 @@ (define/public (set-top-position x y) (unless (and (not x) (not y)) (gtk_widget_set_uposition gtk - (or x -2) - (or y -2)))) + (or (and x (->screen x)) -2) + (or (and y (->screen y)) -2)))) (define/override (really-set-size gtk x y processed-x processed-y w h) (set-top-position x y) - (gtk_window_resize gtk (max 1 w) (max 1 h))) + (gtk_window_resize gtk (max 1 (->screen w)) (max 1 (->screen h)))) (define/override (show on?) (let ([es (get-eventspace)]) @@ -457,8 +458,8 @@ (let-values ([(dx dy) (gtk_window_get_position gtk)] [(cdx cdy) (get-client-delta)]) (gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST) - (set-box! x (+ (unbox x) dx cdx)) - (set-box! y (+ (unbox y) dy cdy)))) + (set-box! x (+ (unbox x) (->normal (+ dx cdx)))) + (set-box! y (+ (unbox y) (->normal (+ dy cdy)))))) (define/public (on-toolbar-click) (void)) (define/public (on-menu-click) (void)) @@ -563,22 +564,24 @@ (define (display-origin x y all? num fail) (let ([r (monitor-rect num fail)]) - (set-box! x (- (GdkRectangle-x r))) - (set-box! y (- (GdkRectangle-y r))))) + (set-box! x (->normal (- (GdkRectangle-x r)))) + (set-box! y (->normal (- (GdkRectangle-y r)))))) (define (display-size w h all? num fail) (let ([r (monitor-rect num fail)]) - (set-box! w (GdkRectangle-width r)) - (set-box! h (GdkRectangle-height r)))) + (set-box! w (->normal (GdkRectangle-width r))) + (set-box! h (->normal (GdkRectangle-height r))))) (define (display-count) (gdk_screen_get_n_monitors (gdk_screen_get_default))) (define (display-bitmap-resolution num fail) + (define (get) (or (get-interface-scale-factor num) + 1.0)) (if (zero? num) - 1.0 + (get) (if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default))) - 1.0 + (get) (fail)))) (define (location->window x y) diff --git a/gui-lib/mred/private/wx/gtk/gsettings.rkt b/gui-lib/mred/private/wx/gtk/gsettings.rkt new file mode 100644 index 00000000..bd65de92 --- /dev/null +++ b/gui-lib/mred/private/wx/gtk/gsettings.rkt @@ -0,0 +1,41 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/alloc + racket/draw/unsafe/glib + racket/draw/private/libs + "types.rkt") + +(provide (protect-out (all-defined-out))) + +(define-runtime-lib gio-lib + [(unix) (ffi-lib "libgio-2.0" '("0" ""))] + [(macosx) + (ffi-lib "libgio-2.0.0.dylib")] + [(windows) + (ffi-lib "libgio-2.0-0.dll")]) + +(define-ffi-definer define-gio gio-lib + #:default-make-fail (lambda (id) (lambda () #f))) + +(define _GSettings-pointer (_cpointer 'GSettings)) +(define _GSettingsSchemeSource-pointer (_cpointer 'GSettingsSchemeSource)) +(define _GVariant-pointer (_cpointer 'GVariant)) + +(define-gobj g_object_unref (_fun _pointer -> _void) + #:wrap (deallocator)) + +(define-gio g_settings_schema_source_get_default (_fun -> _GSettingsSchemeSource-pointer)) +(define-gio g_settings_schema_source_lookup (_fun _GSettingsSchemeSource-pointer + _string + _gboolean + -> _pointer)) + +(define-gio g_settings_new (_fun _string -> _GSettings-pointer) + #:wrap (allocator g_object_unref)) +(define-gio g_settings_get_value (_fun _GSettings-pointer _string -> _GVariant-pointer)) + +(define-glib g_variant_get_type_string (_fun _GVariant-pointer -> _string)) +(define-glib g_variant_get_int32 (_fun _GVariant-pointer -> _int32)) +(define-glib g_variant_get_uint32 (_fun _GVariant-pointer -> _uint32)) +(define-glib g_variant_get_double (_fun _GVariant-pointer -> _gdouble)) diff --git a/gui-lib/mred/private/wx/gtk/item.rkt b/gui-lib/mred/private/wx/gtk/item.rkt index dbfd10bd..d5155174 100644 --- a/gui-lib/mred/private/wx/gtk/item.rkt +++ b/gui-lib/mred/private/wx/gtk/item.rkt @@ -2,6 +2,7 @@ (require ffi/unsafe racket/class racket/draw/private/local + (only-in racket/draw make-font) "../../syntax.rkt" "window.rkt" "utils.rkt" @@ -16,7 +17,19 @@ (define (install-control-font gtk font) (when font - (gtk_widget_modify_font gtk (send font get-pango)))) + (let* ([s (->screen 1)] + [font (if (= s 1) + font + (make-font #:size (->screen (send font get-size)) + #:face (send font get-face) + #:family (send font get-family) + #:style (send font get-style) + #:weight (send font get-weight) + #:underlined? (send font get-underlined) + #:smoothing (send font get-smoothing) + #:size-in-pixels? (send font get-size-in-pixels) + #:hinting (send font get-hinting)))]) + (gtk_widget_modify_font gtk (send font get-pango))))) (defclass item% window% (inherit get-client-gtk) diff --git a/gui-lib/mred/private/wx/gtk/menu.rkt b/gui-lib/mred/private/wx/gtk/menu.rkt index 78f93bfe..ffdea4fe 100644 --- a/gui-lib/mred/private/wx/gtk/menu.rkt +++ b/gui-lib/mred/private/wx/gtk/menu.rkt @@ -132,11 +132,11 @@ (let* ([s (gtk_widget_get_screen menu)] [sw (gdk_screen_get_width s)] [sh (gdk_screen_get_height s)]) - (ptr-set! _x _int (min x + (ptr-set! _x _int (min (->screen x) (max 0 (- sw (GtkRequisition-width r))))) - (ptr-set! _y _int (min y + (ptr-set! _y _int (min (->screen y) (max 0 (- sh (GtkRequisition-height r))))))) diff --git a/gui-lib/mred/private/wx/gtk/message.rkt b/gui-lib/mred/private/wx/gtk/message.rkt index 549fb4b2..4264abc1 100644 --- a/gui-lib/mred/private/wx/gtk/message.rkt +++ b/gui-lib/mred/private/wx/gtk/message.rkt @@ -49,7 +49,7 @@ [(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)] [(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)] [else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])) - (let ([pixbuf (bitmap->pixbuf label)]) + (let ([pixbuf (bitmap->pixbuf label (->screen 1.0))]) (begin0 (as-gtk-allocation (gtk_image_new_from_pixbuf pixbuf)) @@ -67,7 +67,7 @@ [(string? s) (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] [else - (let ([pixbuf (bitmap->pixbuf s)]) + (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))]) (atomically (gtk_image_set_from_pixbuf (get-gtk) pixbuf) (release-pixbuf pixbuf)))])) diff --git a/gui-lib/mred/private/wx/gtk/panel.rkt b/gui-lib/mred/private/wx/gtk/panel.rkt index 4109c47f..3f89c701 100644 --- a/gui-lib/mred/private/wx/gtk/panel.rkt +++ b/gui-lib/mred/private/wx/gtk/panel.rkt @@ -102,8 +102,8 @@ (inherit get-container-gtk) (super-new) (define/override (set-child-size child-gtk x y w h) - (gtk_fixed_move (get-container-gtk) child-gtk x y) - (gtk_widget_set_size_request child-gtk w h)))) + (gtk_fixed_move (get-container-gtk) child-gtk (->screen x) (->screen y)) + (gtk_widget_set_size_request child-gtk (->screen w) (->screen h))))) (define panel% (class (panel-container-mixin (panel-mixin window%)) diff --git a/gui-lib/mred/private/wx/gtk/pixbuf.rkt b/gui-lib/mred/private/wx/gtk/pixbuf.rkt index c875a4fe..e1f3a8a5 100644 --- a/gui-lib/mred/private/wx/gtk/pixbuf.rkt +++ b/gui-lib/mred/private/wx/gtk/pixbuf.rkt @@ -46,26 +46,33 @@ #f #t)) -(define (bitmap->pixbuf bm) - (let* ([w (send bm get-width)] - [h (send bm get-height)] - [str (make-bytes (* w h 4) 255)]) - (send bm get-argb-pixels 0 0 w h str #f) +(define (bitmap->pixbuf orig-bm [scale 1.0]) + (let* ([w (send orig-bm get-width)] + [h (send orig-bm get-height)] + [sw (ceiling (inexact->exact (* scale w)))] + [sh (ceiling (inexact->exact (* scale h)))] + [str (make-bytes (* sw sh 4) 255)]) + (define-values (bm unscaled? usw ush) + (cond + [(= scale 1.0) (values orig-bm #f w h)] + [(= scale (send orig-bm get-backing-scale)) (values orig-bm #t w h)] + [else (values (rescale orig-bm scale) #f sw sh)])) + (send bm get-argb-pixels 0 0 usw ush str #f #:unscaled? unscaled?) (let ([mask (send bm get-loaded-mask)]) (when mask - (send mask get-argb-pixels 0 0 w h str #t))) + (send mask get-argb-pixels 0 0 usw ush str #t #:unscaled? unscaled?))) (atomically - (let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)]) - (memcpy rgba (ptr-add str 1) (sub1 (* w h 4))) - (for ([i (in-range 0 (* w h 4) 4)]) + (let ([rgba (scheme_make_sized_byte_string (malloc (* sw sh 4) 'raw) (* sw sh 4) 0)]) + (memcpy rgba (ptr-add str 1) (sub1 (* sw sh 4))) + (for ([i (in-range 0 (* sw sh 4) 4)]) (bytes-set! rgba (+ i 3) (bytes-ref str i))) (gdk_pixbuf_new_from_data rgba 0 #t 8 - w - h - (* w 4) + sw + sh + (* sw 4) free-it #f))))) @@ -80,3 +87,14 @@ (cairo_fill cr) (cairo_destroy cr) bm)) + +(define (rescale bm scale) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define new-bm (make-bitmap (ceiling (inexact->exact (* scale w))) + (ceiling (inexact->exact (* scale h))))) + (define dc (send new-bm make-dc)) + (send dc set-scale scale scale) + (send dc set-smoothing 'smoothed) + (send dc draw-bitmap bm 0 0) + new-bm) diff --git a/gui-lib/mred/private/wx/gtk/radio-box.rkt b/gui-lib/mred/private/wx/gtk/radio-box.rkt index f610cc7e..26da51ac 100644 --- a/gui-lib/mred/private/wx/gtk/radio-box.rkt +++ b/gui-lib/mred/private/wx/gtk/radio-box.rkt @@ -55,7 +55,7 @@ [(string? lbl) (gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))] [else - (let ([pixbuf (bitmap->pixbuf lbl)]) + (let ([pixbuf (bitmap->pixbuf lbl (->screen 1.0))]) (let ([radio-gtk (gtk_radio_button_new #f)] [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) (release-pixbuf pixbuf) diff --git a/gui-lib/mred/private/wx/gtk/resolution.rkt b/gui-lib/mred/private/wx/gtk/resolution.rkt new file mode 100644 index 00000000..de935e11 --- /dev/null +++ b/gui-lib/mred/private/wx/gtk/resolution.rkt @@ -0,0 +1,21 @@ +#lang racket/base +(require "gsettings.rkt") + +(provide get-interface-scale-factor) + + +(define (get-interface-scale-factor display-num) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (define schema "org.gnome.desktop.interface") + (define gs (and (g_settings_schema_source_lookup + (g_settings_schema_source_get_default) + schema + #f) + (g_settings_new schema))) + (define v + (* (g_variant_get_uint32 + (g_settings_get_value gs "scaling-factor")) + (g_variant_get_double + (g_settings_get_value gs "text-scaling-factor")))) + (g_object_unref gs) + v)) diff --git a/gui-lib/mred/private/wx/gtk/types.rkt b/gui-lib/mred/private/wx/gtk/types.rkt index 15841e07..a1253033 100644 --- a/gui-lib/mred/private/wx/gtk/types.rkt +++ b/gui-lib/mred/private/wx/gtk/types.rkt @@ -14,6 +14,8 @@ _fnpointer _gboolean _gfloat + _gsize + _gdouble _GdkEventButton _GdkEventButton-pointer (struct-out GdkEventButton) @@ -55,6 +57,8 @@ (define _fnpointer _pointer) ; a function pointer that can be NULL (define _gboolean _bool) (define _gfloat _float) +(define _gsize _long) +(define _gdouble _double) (define _GdkEventType _int) (define _GdkAtom _intptr) diff --git a/gui-lib/mred/private/wx/gtk/utils.rkt b/gui-lib/mred/private/wx/gtk/utils.rkt index 2b4e09a0..a48b5bad 100644 --- a/gui-lib/mred/private/wx/gtk/utils.rkt +++ b/gui-lib/mred/private/wx/gtk/utils.rkt @@ -6,7 +6,8 @@ racket/draw/unsafe/glib (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" - "types.rkt") + "types.rkt" + "resolution.rkt") (provide define-mz @@ -48,7 +49,10 @@ gdk_screen_get_default ;; for declaring derived structures: - _GtkObject) + _GtkObject + + ;; window size adjustments for screen scale: + ->screen ->screen* ->normal) mnemonic-string) (define gdk-lib @@ -196,3 +200,29 @@ "__") "_\\1")) "&")) + +;; ---------------------------------------- + +(define screen-scale-factor + (inexact->exact (get-interface-scale-factor 0))) + +(define (->screen x) + (and x + (if (= screen-scale-factor 1) + x + (if (exact? x) + (ceiling (* x screen-scale-factor)) + (* x screen-scale-factor))))) +(define (->screen* x) + (if (and (not (= screen-scale-factor 1)) + (exact? x)) + (floor (* x screen-scale-factor)) + (->screen x))) + +(define (->normal x) + (and x + (if (= screen-scale-factor 1) + x + (if (exact? x) + (floor (/ x screen-scale-factor)) + (/ x screen-scale-factor))))) diff --git a/gui-lib/mred/private/wx/gtk/window.rkt b/gui-lib/mred/private/wx/gtk/window.rkt index 7830dd47..dda963a8 100644 --- a/gui-lib/mred/private/wx/gtk/window.rkt +++ b/gui-lib/mred/private/wx/gtk/window.rkt @@ -175,10 +175,10 @@ (let ([wx (gtk->wx gtk)]) (when wx (send wx save-size - (GtkAllocation-x a) - (GtkAllocation-y a) - (GtkAllocation-width a) - (GtkAllocation-height a)))) + (->normal (GtkAllocation-x a)) + (->normal (GtkAllocation-y a)) + (->normal (GtkAllocation-width a)) + (->normal (GtkAllocation-height a))))) #t)) ;; ---------------------------------------- @@ -368,13 +368,15 @@ [m (let-values ([(x y) (send wx adjust-event-position - (->long ((if motion? - GdkEventMotion-x - (if crossing? GdkEventCrossing-x GdkEventButton-x)) - event)) - (->long ((if motion? GdkEventMotion-y - (if crossing? GdkEventCrossing-y GdkEventButton-y)) - event)))]) + (->normal + (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event))) + (->normal + (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event))))]) (new mouse-event% [event-type type] [left-down (case type @@ -505,8 +507,9 @@ (send parent set-child-size gtk x y w h)) (define/public (set-child-size child-gtk x y w h) - (gtk_widget_set_size_request child-gtk w h) - (gtk_widget_size_allocate child-gtk (make-GtkAllocation x y w h))) + (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)) + (gtk_widget_size_allocate child-gtk (make-GtkAllocation (->screen x) (->screen y) + (->screen w) (->screen h)))) (define/public (remember-size x y w h) ;; called in event-pump thread @@ -538,20 +541,22 @@ (when sub-h-gtk (gtk_widget_size_request sub-h-gtk hreq)) (when w? - (set! client-delta-w (- (GtkRequisition-width req) - (max (GtkRequisition-width creq) - (GtkRequisition-width hreq))))) + (set! client-delta-w (->normal + (- (GtkRequisition-width req) + (max (GtkRequisition-width creq) + (GtkRequisition-width hreq)))))) (when h? - (set! client-delta-h (- (GtkRequisition-height req) - (GtkRequisition-height creq)))))) + (set! client-delta-h (->normal + (- (GtkRequisition-height req) + (GtkRequisition-height creq))))))) (define/public (set-auto-size [dw 0] [dh 0]) (let ([req (make-GtkRequisition 0 0)]) (gtk_widget_size_request gtk req) (set-size #f #f - (+ (GtkRequisition-width req) dw) - (+ (GtkRequisition-height req) dh)))) + (+ (->normal (GtkRequisition-width req)) dw) + (+ (->normal (GtkRequisition-height req)) dh)))) (define shown? #f) (define/public (direct-show on?) @@ -765,8 +770,8 @@ (client-to-screen xb yb) (gdk_display_warp_pointer (gtk_widget_get_display gtk) (gtk_widget_get_screen gtk) - (unbox xb) - (unbox yb))) + (->screen (unbox xb)) + (->screen (unbox yb)))) (define/public (gets-focus?) #t)))