From a64a1cb17722a49558ee76b5400d54aa040d1825 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Sep 2014 08:40:34 -0600 Subject: [PATCH] racket/gui: DPI-aware on Windows The `racket/draw` library is now independent of the screen resolution on Windows. Font sizes in "points" are the only place where the resolution mattered before, and now `racket/draw` assumes a traditional 96dpi on Windows and Linux (and a traditional 72dpi on Mac OS X). Setting the scale for "text and other items" in Windows now adjusts the backing scale of screen and canvas-compatible bitmaps, as well as setting a scale on canvas drawing. Window and screen positions and sizes are similarly scaled; for example, if the screen is 2048x1436 with text scaled by 200%, then `racket/gui` reports the display size as 1024x768 (and the display backing scale as 2.0). Backing scales of 1.25 and 1.5 are common for Windows. Rounding associated with those scales could cause trouble for virtual -> actual -> virtual conversions. --- .../scribblings/draw/bitmap-class.scrbl | 6 +- .../scribblings/draw/font-class.scrbl | 5 +- .../draw-doc/scribblings/draw/guide.scrbl | 48 +++++------ .../draw-lib/racket/draw/private/bitmap.rkt | 8 +- .../draw-lib/racket/draw/private/font.rkt | 14 ++- .../scribblings/gui/global-draw-funcs.scrbl | 17 ++-- .../scribblings/gui/miscwin-funcs.scrbl | 5 +- .../scribblings/gui/win-overview.scrbl | 27 ++++++ .../mred/private/wx/common/backing-dc.rkt | 56 +++++++----- .../gui-lib/mred/private/wx/win32/canvas.rkt | 28 +++--- .../gui-lib/mred/private/wx/win32/const.rkt | 2 + .../gui-lib/mred/private/wx/win32/dc.rkt | 33 ++++--- .../gui-lib/mred/private/wx/win32/font.rkt | 15 +++- .../gui-lib/mred/private/wx/win32/frame.rkt | 85 +++++++++---------- .../gui-lib/mred/private/wx/win32/gcwin.rkt | 2 +- .../mred/private/wx/win32/group-panel.rkt | 5 +- .../gui-lib/mred/private/wx/win32/hbitmap.rkt | 8 +- .../mred/private/wx/win32/list-box.rkt | 8 +- .../gui-lib/mred/private/wx/win32/menu.rkt | 2 +- .../gui-lib/mred/private/wx/win32/panel.rkt | 2 +- .../mred/private/wx/win32/printer-dc.rkt | 14 +-- .../gui-lib/mred/private/wx/win32/procs.rkt | 2 +- .../mred/private/wx/win32/radio-box.rkt | 10 ++- .../gui-lib/mred/private/wx/win32/slider.rkt | 12 ++- .../mred/private/wx/win32/tab-panel.rkt | 6 +- .../gui-lib/mred/private/wx/win32/utils.rkt | 37 +++++++- .../gui-lib/mred/private/wx/win32/window.rkt | 52 ++++++------ pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt | 9 +- racket/src/worksp/gracket/gracket.manifest | 7 +- racket/src/worksp/racket/racket.manifest | 7 +- 30 files changed, 334 insertions(+), 198 deletions(-) diff --git a/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl b/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl index 8782f61b8a..f851f35b86 100644 --- a/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl +++ b/pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl @@ -15,8 +15,10 @@ A bitmap has a @deftech{backing scale}, which is the number of pixels 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]. A monochrome bitmap always has a - backing scale of @racket[1.0]. + backing scale is @racket[2.0]. On Windows, the backing scale of a screen + bitmap corresponds to the system-wide text scale (see @secref[#:doc '(lib + "scribblings/gui/gui.scrbl") "display-resolution"]). A monochrome bitmap always + has a backing scale of @racket[1.0]. A bitmap is convertible to @racket['png-bytes] through the @racketmodname[file/convertible] protocol. diff --git a/pkgs/draw-pkgs/draw-doc/scribblings/draw/font-class.scrbl b/pkgs/draw-pkgs/draw-doc/scribblings/draw/font-class.scrbl index 639d1e8e13..9e22669458 100644 --- a/pkgs/draw-pkgs/draw-doc/scribblings/draw/font-class.scrbl +++ b/pkgs/draw-pkgs/draw-doc/scribblings/draw/font-class.scrbl @@ -76,7 +76,8 @@ A @defterm{font} is an object which determines the appearance of text, @item{size-in-pixels? --- @racket[#t] if the size of the font is in logical drawing units (i.e., pixels for an unscaled screen or bitmap drawing context), @racket[#f] if the size of the font is in - points (which can depend on screen resolution).} + ``points'', where a ``point'' is equal to 1 pixel on Max OS X and + @racket[(/ 96 72)] pixels on Windows and Unix} @item{hinting --- Whether font metrics should be rounded to integers: @itemize[ @@ -94,6 +95,8 @@ To avoid creating multiple fonts with the same characteristics, use See also @racket[font-name-directory<%>]. +@history[#:changed "1.2" @elem{Defined ``points'' as @racket[(/ 96 72)] pixels on Windows, + independent of the screen resolution.}] @defconstructor*/make[(() diff --git a/pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl b/pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl index 95b830f477..e62764698e 100644 --- a/pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl +++ b/pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl @@ -751,31 +751,22 @@ Different kinds of bitmaps can produce different results: constrained resources only during the drawing process.} @item{Drawing to a bitmap produced by @racket[make-screen-bitmap] - from @racketmodname[racket/gui/base] or by @xmethod[canvas% - 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. 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 - when consistency with screen drawing is needed for some other - reason.} - - @item{Drawing to a bitmap produced by @racket[make-screen-bitmap] - from @racketmodname[racket/gui/base] - 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. 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. + from @racketmodname[racket/gui/base] uses the same + platform-specific drawing operations as drawing into a + @racket[canvas%] instance. A bitmap produced by + @racket[make-screen-bitmap] uses the same platform-specific + drawing as @racket[make-platform-bitmap] on Windows or Mac OS + X, but possibly scaled, and 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. Similarly, on + Windows, when the main display's text scale is configured at + the operating-system level (see @secref[#:doc '(lib + "scribblings/gui/gui.scrbl") "display-resolution"]), the bitmap + is internally scaled, where common configurations map a drawing + unit to @math{1.25}, @math{1.5}, or @math{2} pixels. Use @racket[make-screen-bitmap] when drawing to a bitmap as an offscreen buffer before transferring an image to the screen, or @@ -787,9 +778,12 @@ Different kinds of bitmaps can produce different results: @racket[make-screen-bitmap], but on Mac OS X, the bitmap is optimized for drawing to the screen (by taking advantage of system APIs that can, in turn, take advantage of graphics - hardware).} + hardware). + + Use @xmethod[canvas% make-bitmap] for similar purposes + as @racket[make-screen-bitmap], particularly when the bitmap + will be drawn later to a known target canvas.} ] - @close-eval[draw-eval] diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt index 20c8eaaeba..df0c728c16 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt @@ -1008,15 +1008,17 @@ (init w h backing-scale) (super-make-object (make-alternate-bitmap-kind w h backing-scale)) - (define s (build-cairo-surface w h)) + (define s (build-cairo-surface w h backing-scale)) ;; erase the bitmap (let ([cr (cairo_create s)]) (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) (cairo_paint cr) (cairo_destroy cr)) - (define/public (build-cairo-surface w h) - (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)) + (define/public (build-cairo-surface w h backing-scale) + (let ([sw (*i backing-scale w)] + [sh (*i backing-scale h)]) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 sw sh))) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt index aa1c779191..a8f82daf4d 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt @@ -119,6 +119,15 @@ (cairo_destroy cr) (cairo_surface_destroy s)))) +(define dpi-scale + ;; Hard-wire 96dpi for Windows and Linux, but 72 dpi for Mac OS X + ;; (based on historical defaults on those platforms). + ;; If the actual DPI for the screen is different, we'll handle + ;; that by scaling to and from the screen. + (if (eq? 'macosx (system-type)) + 1.0 + (/ 96.0 72.0))) + (defclass font% object% (define table-key #f) @@ -173,9 +182,8 @@ [(normal) PANGO_WEIGHT_MEDIUM] [(light) PANGO_WEIGHT_LIGHT] [(bold) PANGO_WEIGHT_BOLD]))) - (if size-in-pixels? - (pango_font_description_set_absolute_size desc (* size PANGO_SCALE)) - (pango_font_description_set_size desc (inexact->exact (floor (* size PANGO_SCALE))))) + (let ([size (if size-in-pixels? size (* dpi-scale size))]) + (pango_font_description_set_absolute_size desc (* size PANGO_SCALE))) (install! desc) (atomically (hash-set! font-descs key desc)) desc))) diff --git a/pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl b/pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl index 023550a39a..4e458d30b9 100644 --- a/pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl +++ b/pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl @@ -18,15 +18,19 @@ other actions depend on updating the display.} (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. +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 +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 @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].} + @xmethod[top-level-window<%> display-changed]. + +@history[#:changed "1.2" @elem{Added backing-scale support on Windows.}]} @defproc[(get-display-count) exact-positive-integer?]{ @@ -70,7 +74,8 @@ When the optional @racket[avoid-bars?] argument is true, for @racket[monitor] If @racket[monitor] is not less than the current number of available monitors (which can change at any time), the results are @racket[#f] and @racket[#f]. See also @xmethod[top-level-window<%> display-changed]. -} + +See also @secref["display-resolution"].} @defproc[(get-display-size [full-screen? any/c #f] @@ -93,7 +98,9 @@ On Windows and Mac OS X, if the optional argument is true and @racket[monitor] i If @racket[monitor] is not less than the current number of available monitors (which can change at any time), the results are @racket[#f] and @racket[#f]. See also @xmethod[top-level-window<%> display-changed]. -} + +See also @secref["display-resolution"].} + @defproc[(is-color-display?) diff --git a/pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl b/pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl index 9a4d0fe51f..1d9661baeb 100644 --- a/pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl +++ b/pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl @@ -280,8 +280,9 @@ canvas in its default configuration. 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]. +@racket[width] and @racket[height]. On Windows, the backing scale +is similarly increased by adjusting the operating-system text scale. +See also @racket[get-display-backing-scale]. See also @secref[#:doc '(lib "scribblings/draw/draw.scrbl") "Portability"].} diff --git a/pkgs/gui-pkgs/gui-doc/scribblings/gui/win-overview.scrbl b/pkgs/gui-pkgs/gui-doc/scribblings/gui/win-overview.scrbl index 5c2a5e9d5f..a3ab1905e1 100644 --- a/pkgs/gui-pkgs/gui-doc/scribblings/gui/win-overview.scrbl +++ b/pkgs/gui-pkgs/gui-doc/scribblings/gui/win-overview.scrbl @@ -999,3 +999,30 @@ suspend-flush] will soon follow, because the process of flushing to the screen can be starved if flushing is frequently suspend. The method @xmethod[canvas% refresh-now] conveniently encapsulates this sequence. + +@; ---------------------------------------- + +@section[#:tag "display-resolution"]{Screen Resolution and Text Scaling} + +On Mac OS X, screen sizes are described to users in terms of drawing +units. A Retina display provides two pixels per drawing unit, while +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, +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 +GUI elements, including the screen, windows, buttons, and canvas +drawing. For example, if the scale is 200%, then the screen size +reported by @racket[get-display-size] will be half of the number of +pixels in each dimension. Beware that round-off effects can cause the +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. diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt index 45c7936298..0836b15551 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt @@ -175,35 +175,51 @@ (define (release-backing-bitmap bm) (send bm release-bitmap-storage)) +(define (scale-mixin %) + (class % + (define backing-scale 1.0) + + (super-new) + + (define/override (init-cr-matrix cr) + (unless (= backing-scale 1.0) + (cairo_scale cr backing-scale backing-scale)) + (super init-cr-matrix cr)) + + (define/override (reset-config s) + (set! backing-scale s) + (super reset-config)))) + (define cairo-dc - (make-object (dc-mixin - (class default-dc-backend% - (inherit reset-cr) + (make-object (scale-mixin + (dc-mixin + (class default-dc-backend% + (inherit reset-cr) - (define cr #f) - (define w 0) - (define h 0) + (define cr #f) + (define w 0) + (define h 0) - (super-new) + (super-new) - (define/public (set-cr new-cr new-w new-h) - (set! cr new-cr) - (set! w new-w) - (set! h new-h) - (when cr - (reset-cr cr))) + (define/public (set-cr new-cr new-w new-h) + (set! cr new-cr) + (set! w new-w) + (set! h new-h) + (when cr + (reset-cr cr))) - (define/override (get-cr) cr) + (define/override (get-cr) cr) - (define/override (reset-clip cr) - (super reset-clip cr) - (cairo_rectangle cr 0 0 w h) - (cairo_clip cr)))))) + (define/override (reset-clip cr) + (super reset-clip cr) + (cairo_rectangle cr 0 0 w h) + (cairo_clip cr))))))) -(define (backing-draw-bm bm cr w h [dx 0] [dy 0]) +(define (backing-draw-bm bm cr w h [dx 0] [dy 0] [backing-scale 1.0]) (if (procedure? bm) (begin - (send cairo-dc reset-config) + (send cairo-dc reset-config backing-scale) (send cairo-dc set-cr cr w h) (unless (and (zero? dx) (zero? dy)) (send cairo-dc translate dx dy)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/canvas.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/canvas.rkt index 9a8ecec17c..0a84def6dc 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/canvas.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/canvas.rkt @@ -105,7 +105,7 @@ "PLTTabPanel" #f (bitwise-ior WS_CHILD) - 0 0 w h + 0 0 (->screen w) (->screen h) (send parent get-content-hwnd) #f hInstance @@ -122,7 +122,7 @@ (if panel-hwnd WS_VISIBLE 0) (if hscroll? WS_HSCROLL 0) (if vscroll? WS_VSCROLL 0)) - 0 0 w h + 0 0 (->screen w) (->screen h) (or panel-hwnd (send parent get-content-hwnd)) #f hInstance @@ -136,7 +136,7 @@ CBS_DROPDOWNLIST WS_HSCROLL WS_VSCROLL WS_BORDER WS_CLIPSIBLINGS) - 0 0 w h + 0 0 (->screen w) (->screen h) panel-hwnd #f hInstance @@ -148,7 +148,7 @@ "PLTTabPanel" #f (bitwise-ior WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) - 0 0 w h + 0 0 (->screen w) (->screen h) canvas-hwnd #f hInstance @@ -282,10 +282,10 @@ (when panel-hwnd (let* ([r (and (or (= w -1) (= h -1)) (GetWindowRect hwnd))] - [w (if (= w -1) (- (RECT-right r) (RECT-left r)) w)] - [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) - (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) - (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t))) + [w (if (= w -1) (->normal (- (RECT-right r) (RECT-left r))) w)] + [h (if (= h -1) (->normal (- (RECT-bottom r) (RECT-top r))) h)]) + (MoveWindow canvas-hwnd 0 0 (->screen (max 1 (- w COMBO-WIDTH))) (->screen h) #t) + (MoveWindow combo-hwnd 0 0 (->screen (max 1 w)) (->screen (- h 2)) #t))) (when (and (is-auto-scroll?) (not (is-panel?))) (reset-auto-scroll)) @@ -618,14 +618,14 @@ (define/override (notify-child-extent x y) (let* ([content-hwnd (get-content-hwnd)] [r (GetWindowRect content-hwnd)] - [w (- (RECT-right r) (RECT-left r))] - [h (- (RECT-bottom r) (RECT-top r))]) + [w (->normal (- (RECT-right r) (RECT-left r)))] + [h (->normal (- (RECT-bottom r) (RECT-top r)))]) (when (or (> x w) (> y h)) (let ([pr (GetWindowRect (get-client-hwnd))]) (MoveWindow content-hwnd - (- (RECT-left r) (RECT-left pr)) + (- (RECT-left r) (RECT-left pr)) (- (RECT-top r) (RECT-top pr)) - (max w x) (max y h) + (->screen (max w x)) (->screen (max y h)) #t))))) (define/override (reset-dc-for-autoscroll) @@ -635,8 +635,8 @@ [w (- (RECT-right r) (RECT-left r))] [h (- (RECT-bottom r) (RECT-top r))]) (MoveWindow content-hwnd - (- (get-virtual-h-pos)) - (- (get-virtual-v-pos)) + (->screen (- (get-virtual-h-pos))) + (->screen (- (get-virtual-v-pos))) w h #t))) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/const.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/const.rkt index 0ace67bffd..0bbba5c8b9 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/const.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/const.rkt @@ -611,6 +611,8 @@ (define HORZRES 8) (define VERTRES 10) +(define LOGPIXELSX 88) +(define LOGPIXELSY 90) (define CBS_DROPDOWNLIST #x0003) (define CB_INSERTSTRING #x014A) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/dc.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/dc.rkt index 5ad449a3c5..541b0bd4c1 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/dc.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/dc.rkt @@ -36,18 +36,20 @@ (init w h hwnd [gl-config #f]) (inherit get-cairo-surface) (parameterize ([hwnd-param hwnd]) - (super-new [w w] [h h] [backing-scale 1.0])) + (super-new [w w] [h h] [backing-scale (->screen 1.0)])) - (define/override (build-cairo-surface w h) + (define/override (build-cairo-surface w h backing-scale) (define hwnd (hwnd-param)) (if hwnd (atomically (let ([hdc (GetDC hwnd)]) (begin0 - (cairo_win32_surface_create_with_ddb hdc - CAIRO_FORMAT_RGB24 w h) + (let ([sw (inexact->exact (floor (* backing-scale w)))] + [sh (inexact->exact (floor (* backing-scale h)))]) + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 sw sh)) (ReleaseDC hwnd hdc)))) - (super build-cairo-surface w h))) + (super build-cairo-surface w h backing-scale))) (define gl (and gl-config (let ([hdc (cairo_win32_surface_get_dc (get-cairo-surface))]) @@ -89,12 +91,11 @@ #f)]) (when v (set! gl v)) v))) - (define/override (make-backing-bitmap w h) (if (send canvas get-canvas-background) (make-object win32-bitmap% w h (send canvas get-hwnd)) - (super make-backing-bitmap w h))) + (make-object bitmap% w h #f #t (->screen 1.0)))) (define/override (get-backing-size xb yb) (send canvas get-client-size xb yb)) @@ -125,7 +126,9 @@ (let ([w (box 0)] [h (box 0)]) (send canvas get-client-size w h) - (define r (make-RECT 0 0 (unbox w) (unbox h))) + (define sw (->screen (unbox w))) + (define sh (->screen (unbox h))) + (define r (make-RECT 0 0 sw sh)) (define clip-type (if win64? (GetClipBox hdc r) @@ -135,8 +138,8 @@ (not (and (= clip-type SIMPLEREGION) (= (RECT-left r) 0) (= (RECT-top r) 0) - (= (RECT-right r) (unbox w)) - (= (RECT-bottom r) (unbox h))))) + (= (RECT-right r) sw) + (= (RECT-bottom r) sh)))) ;; Another workaround: a clipping region installed by BeginPaint() ;; seems to interfere with Cairo drawing. So, draw to a ;; fresh context and copy back and forth using Win32. @@ -149,7 +152,10 @@ [cr (cairo_create surface)] [hdc2 (cairo_win32_surface_get_dc surface)]) (BitBlt hdc2 0 0 cw ch hdc (RECT-left r) (RECT-top r) SRCCOPY) - (backing-draw-bm bm cr (unbox w) (unbox h) (- (RECT-left r)) (- (RECT-top r))) + (cairo_scale cr (->screen 1.0) (->screen 1.0)) + (backing-draw-bm bm cr (->normal sw) (->normal sh) + (->normal (- (RECT-left r))) (->normal (- (RECT-top r))) + (->screen 1.0)) (cairo_surface_flush surface) (BitBlt hdc (RECT-left r) (RECT-top r) cw ch hdc2 0 0 SRCCOPY) (cairo_surface_destroy surface) @@ -158,7 +164,10 @@ (let* ([surface (cairo_win32_surface_create hdc)] [cr (cairo_create surface)]) (cairo_surface_destroy surface) - (backing-draw-bm bm cr (unbox w) (unbox h)) + (cairo_scale cr (->screen 1.0) (->screen 1.0)) + (backing-draw-bm bm cr (->normal sw) (->normal sh) + 0 0 + (->screen 1.0)) (cairo_destroy cr))]))))) (define (request-flush-delay canvas) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/font.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/font.rkt index 2da8ac2948..25c1a799fb 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/font.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/font.rkt @@ -21,10 +21,23 @@ (define font-cache (pango_win32_font_cache_new)) +(define (scale-font f) + (if (= 1 (->screen 1)) + f + (make-font #:size (->screen (send f get-point-size)) + #:face (send f get-face) + #:family (send f get-family) + #:style (send f get-style) + #:weight (send f get-weight) + #:underlined? (send f get-underlined) + #:smoothing (send f get-smoothing) + #:size-in-pixels? (send f get-size-in-pixels) + #:hinting (send f get-hinting)))) + (define (font->hfont f) (let* ([pfont (or (pango_font_map_load_font display-font-map display-context - (send f get-pango)) + (send (scale-font f) get-pango)) ;; font load failed, so fall back to default ;; font with the same size and style: (pango_font_map_load_font display-font-map diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/frame.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/frame.rkt index 80aef820b0..1f511cf715 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/frame.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/frame.rkt @@ -30,8 +30,6 @@ (define-user32 SetFocus (_wfun _HWND -> _HWND)) (define-user32 BringWindowToTop (_wfun _HWND -> (r : _BOOL) -> (unless r (failed 'BringWindowToTop)))) -(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) - (define-user32 DrawMenuBar (_wfun _HWND -> (r : _BOOL) -> (unless r (failed 'DrawMenuBar)))) @@ -98,10 +96,10 @@ ;; otherwise, preserve order: pos ;; monitor rectangle, which is the goal: - (list (RECT-left r) - (RECT-top r) - (RECT-right r) - (RECT-bottom r))) + (list (->normal (RECT-left r)) + (->normal (RECT-top r)) + (->normal (RECT-right r)) + (->normal (RECT-bottom r)))) rects)) #t) #f) @@ -125,14 +123,14 @@ [all? (atomically (let ([hdc (GetDC #f)]) - (set-box! xb (GetDeviceCaps hdc HORZRES)) - (set-box! yb (GetDeviceCaps hdc VERTRES)) + (set-box! xb (->normal (GetDeviceCaps hdc HORZRES))) + (set-box! yb (->normal (GetDeviceCaps hdc VERTRES))) (ReleaseDC #f hdc)))] [else (let ([r (make-RECT 0 0 0 0)]) (SystemParametersInfoW SPI_GETWORKAREA 0 r 0) - (set-box! xb (- (RECT-right r) (RECT-left r))) - (set-box! yb (- (RECT-bottom r) (RECT-top r))))])) + (set-box! xb (->normal (- (RECT-right r) (RECT-left r)))) + (set-box! yb (->normal (- (RECT-bottom r) (RECT-top r)))))])) (define (display-origin xb yb avoid-bars? num fail) (cond @@ -146,8 +144,8 @@ [avoid-bars? (let ([r (make-RECT 0 0 0 0)]) (SystemParametersInfoW SPI_GETWORKAREA 0 r 0) - (set-box! xb (RECT-left r)) - (set-box! yb (RECT-top r)))] + (set-box! xb (->normal (RECT-left r))) + (set-box! yb (->normal (RECT-top r))))] [else (set-box! xb 0) (set-box! yb 0)])) @@ -163,7 +161,7 @@ (define (display-bitmap-resolution num fail) (if (or (zero? num) (num . < . (display-count))) - 1.0 + (->screen 1.0) (fail))) (define mouse-frame #f) @@ -224,9 +222,9 @@ 0 (bitwise-ior WS_CAPTION WS_MINIMIZEBOX))) - (or x CW_USEDEFAULT) - (or y CW_USEDEFAULT) - w h + (if x (->screen x) CW_USEDEFAULT) + (if y (->screen y) CW_USEDEFAULT) + (->screen w) (->screen h) #f #f hInstance @@ -359,16 +357,16 @@ (when (or max-width max-height) (set-MINMAXINFO-ptMaxTrackSize! mmi - (make-POINT (or max-width + (make-POINT (or (->screen max-width) (POINT-x (MINMAXINFO-ptMaxTrackSize mmi))) - (or max-height + (or (->screen max-height) (POINT-y (MINMAXINFO-ptMaxTrackSize mmi)))))) (when (or min-width min-height) (set-MINMAXINFO-ptMinTrackSize! mmi - (make-POINT (or min-width + (make-POINT (or (->screen min-width) (POINT-x (MINMAXINFO-ptMinTrackSize mmi))) - (or min-height + (or (->screen min-height) (POINT-y (MINMAXINFO-ptMinTrackSize mmi))))))) 0] [(= msg WM_DISPLAYCHANGE) @@ -517,22 +515,24 @@ (set-box! wh (unbox sh)))) (get-size w h) (MoveWindow hwnd - (if (or (eq? mode 'both) - (eq? mode 'horizontal)) - (max 0 - (min (- (unbox sw) (unbox w)) - (+ (quotient (- (unbox ww) (unbox w)) 2) - (unbox wx)))) - (get-x)) - (if (or (eq? mode 'both) - (eq? mode 'vertical)) - (max 0 - (min (- (unbox sh) (unbox h)) - (+ (quotient (- (unbox wh) (unbox h)) 2) - (unbox wy)))) - (get-x)) - (unbox w) - (unbox h) + (->screen + (if (or (eq? mode 'both) + (eq? mode 'horizontal)) + (max 0 + (min (- (unbox sw) (unbox w)) + (+ (quotient (- (unbox ww) (unbox w)) 2) + (unbox wx)))) + (get-x))) + (->screen + (if (or (eq? mode 'both) + (eq? mode 'vertical)) + (max 0 + (min (- (unbox sh) (unbox h)) + (+ (quotient (- (unbox wh) (unbox h)) 2) + (unbox wy)))) + (get-x))) + (->screen (unbox w)) + (->screen (unbox h)) #t))) (define saved-child #f) @@ -593,8 +593,8 @@ (if (iconized?) (let ([wp (get-placement)]) (let ([r (WINDOWPLACEMENT-rcNormalPosition wp)]) - (set-box! w (- (RECT-right r) (RECT-left r))) - (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (set-box! w (->normal (- (RECT-right r) (RECT-left r)))) + (set-box! h (->normal (- (RECT-bottom r) (RECT-top r)))))) (super get-size w h))) (define/override (get-client-size w h) @@ -608,14 +608,14 @@ (define/override (get-x) (if (iconized?) (let ([wp (get-placement)]) - (RECT-left (WINDOWPLACEMENT-rcNormalPosition wp))) - (RECT-left (GetWindowRect hwnd)))) + (->normal (RECT-left (WINDOWPLACEMENT-rcNormalPosition wp)))) + (->normal (RECT-left (GetWindowRect hwnd))))) (define/override (get-y) (if (iconized?) (let ([wp (get-placement)]) - (RECT-top (WINDOWPLACEMENT-rcNormalPosition wp))) - (RECT-top (GetWindowRect hwnd)))) + (->normal (RECT-top (WINDOWPLACEMENT-rcNormalPosition wp)))) + (->normal (RECT-top (GetWindowRect hwnd))))) (define/override (get-width) (if (iconized?) @@ -688,4 +688,3 @@ (popup-menu-with-char #\space)) (define/public (display-changed) (void))) - diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/gcwin.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/gcwin.rkt index 3bb5a83e05..1fde4f6e9f 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/gcwin.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/gcwin.rkt @@ -33,7 +33,7 @@ (vector (vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap) (vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void - BitBlt/raw hdc x y w h blit-hdc 0 0 SRCCOPY) + BitBlt/raw hdc (->screen x) (->screen y) (->screen w) (->screen h) blit-hdc 0 0 SRCCOPY) (vector 'ptr_ptr->void SelectObject/raw blit-hdc #f))) (define (make-gc-show-desc hdc hbitmap x y w h) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/group-panel.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/group-panel.rkt index dd58feead3..fb1fa128ce 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/group-panel.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/group-panel.rkt @@ -40,7 +40,7 @@ "PLTTabPanel" #f (bitwise-ior WS_CHILD WS_VISIBLE) - 0 0 w h + 0 0 (->screen w) (->screen h) hwnd #f hInstance @@ -69,4 +69,5 @@ (define/override (set-size x y w h) (super set-size x y w h) (unless (or (= w -1) (= h -1)) - (MoveWindow client-hwnd 3 (+ label-h 3) (- w 6) (- h label-h 6) #t))))) + (MoveWindow client-hwnd (->screen 3) (->screen (+ label-h 3)) + (->screen (- w 6)) (->screen (- h label-h 6)) #t))))) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/hbitmap.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/hbitmap.rkt index ecb9b01503..560295e8eb 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/hbitmap.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/hbitmap.rkt @@ -25,7 +25,7 @@ ;; RGB win32 bitmaps to RGB win32 bitmaps in a ;; way that sometimes mangles the alpha; avoid the ;; problem by first copying to a Cairo memory bitmap. - (let* ([new-b (make-object bitmap% w h #f #f)] + (let* ([new-b (make-object bitmap% w h #f #f (send bm get-backing-scale))] [dc (make-object bitmap-dc% new-b)]) (send dc draw-bitmap bm 0 0) (send dc set-bitmap #f) @@ -36,14 +36,18 @@ [to-frac (lambda (v) (/ v 255.0))] [screen-hdc (GetDC #f)] [hdc (CreateCompatibleDC screen-hdc)] + [sc (->screen 1.0)] + [scaled (lambda (v) (inexact->exact (ceiling (* v sc))))] [hbitmap (if b&w? (CreateBitmap w h 1 1 #f) - (CreateCompatibleBitmap screen-hdc w h))] + (CreateCompatibleBitmap screen-hdc (scaled w) (scaled h)))] [old-hbitmap (SelectObject hdc hbitmap)]) (ReleaseDC #f screen-hdc) (let* ([s (cairo_win32_surface_create hdc)] [cr (cairo_create s)]) (cairo_surface_destroy s) + (unless (= sc 1) + (cairo_scale cr sc sc)) (cairo_set_source_rgba cr (to-frac (GetRValue bg)) (to-frac (GetGValue bg)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/list-box.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/list-box.rkt index a227b47c9b..635e842ce2 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/list-box.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/list-box.rkt @@ -371,8 +371,8 @@ (set! max-col-width mx)) (atomically (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)]) - (set-LVCOLUMN-cx! col-desc w) - (set-LVCOLUMN-cxMin! col-desc mn) + (set-LVCOLUMN-cx! col-desc (->screen w)) + (set-LVCOLUMN-cxMin! col-desc (->screen mn)) (SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc) (set! min-col-width mn) (set! max-col-width mx))))) @@ -381,7 +381,7 @@ (atomically (let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)]) (SendMessageW/ptr hwnd LVM_GETCOLUMNW col col-desc) - (let ([v (LVCOLUMN-cx col-desc)]) + (let ([v (->normal (LVCOLUMN-cx col-desc))]) (values (max v min-col-width) ; in XP, may have been sized too small min-col-width max-col-width))))) @@ -417,7 +417,7 @@ (define/public (number-of-visible-items) (if single-column? - (let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)]) + (let ([ih (->normal (SendMessageW hwnd LB_GETITEMHEIGHT 0 0))]) (let ([w (box 0)] [h (box 0)]) (get-client-size w h) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/menu.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/menu.rkt index 66205b4c09..20923036da 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/menu.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/menu.rkt @@ -67,7 +67,7 @@ TPM_RIGHTBUTTON TPM_NONOTIFY TPM_RETURNCMD) - gx gy + (->screen gx) (->screen gy) 0 hwnd #f)]) (let* ([e (new popup-event% [event-type 'menu-popdown])]) (unless (zero? cmd) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/panel.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/panel.rkt index 6d10c5cc71..6f5385a8fe 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/panel.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/panel.rkt @@ -112,7 +112,7 @@ (if (memq 'border style) WS_BORDER 0)) - 0 0 w h + 0 0 (->screen w) (->screen h) (send parent get-content-hwnd) #f hInstance diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/printer-dc.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/printer-dc.rkt index 7d44c06baf..486b26ee56 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/printer-dc.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/printer-dc.rkt @@ -78,10 +78,6 @@ (define-gdi32 EndPage (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndPage)))) (define-gdi32 EndDoc (_wfun _HDC -> (r : _int) -> (unless (positive? r) (failed 'EndDoc)))) -(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) - -(define LOGPIXELSX 88) -(define LOGPIXELSY 90) (define PHYSICALOFFSETX 112) (define PHYSICALOFFSETY 113) @@ -124,13 +120,9 @@ ;; the hDevModes and hDevNames fields r))))) -;; Pango uses the resolution of the screen to make point<->pixel -;; decisions for all devices (by default). So, we make on drawing unit in -;; a printing context match the relative drawing unit for the screen. -(define SCREEN-DPI (let ([hdc (GetDC #f)]) - (begin0 - (exact->inexact (GetDeviceCaps hdc LOGPIXELSX)) - (ReleaseDC #f hdc)))) +;; Make on drawing unit in a printing context match the relative drawing +;; unit for the screen, where the conceptual drawing unit is always 96dpi +(define SCREEN-DPI 96) (define printer-dc% (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/procs.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/procs.rkt index e557c4037b..8851fb8db6 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/procs.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/procs.rkt @@ -84,7 +84,7 @@ (define (get-double-click-time) 500) (define (get-control-font-face) (get-theme-font-face)) -(define (get-control-font-size) (get-theme-font-size)) +(define (get-control-font-size) (->normal (get-theme-font-size))) (define (get-control-font-size-in-pixels?) #t) (define-user32 MessageBeep (_wfun _UINT -> _BOOL)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/radio-box.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/radio-box.rkt index de97269650..4d6ae04ad1 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/radio-box.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/radio-box.rkt @@ -53,7 +53,7 @@ (let loop ([y 0] [w 0] [labels labels]) (if (null? labels) (begin - (MoveWindow hwnd 0 0 w y #t) + (MoveWindow hwnd 0 0 (->screen w) (->screen y) #t) null) (let* ([label (car labels)] [bitmap? (label . is-a? . bitmap%)] @@ -83,8 +83,12 @@ (auto-size font label 0 0 20 4 (lambda (w1 h1) (if horiz? - (MoveWindow radio-hwnd (+ w SEP) 0 w1 h1 #t) - (MoveWindow radio-hwnd 0 (+ y SEP) w1 h1 #t)) + (MoveWindow radio-hwnd (->screen (+ w SEP)) 0 + (->screen w1) (->screen h1) + #t) + (MoveWindow radio-hwnd 0 (->screen (+ y SEP)) + (->screen w1) (->screen h1) + #t)) (values w1 h1)))]) (cons radio-hwnd (loop (if horiz? (max y h) (+ y SEP h)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/slider.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/slider.rkt index 4321610a1f..ef20805c1d 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/slider.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/slider.rkt @@ -134,11 +134,15 @@ (unless (or (= w -1) (= h -1)) (if vertical? (let ([dx (quotient (- w THICKNESS value-w) 2)]) - (MoveWindow slider-hwnd dx 0 THICKNESS h #T) - (MoveWindow value-hwnd (+ dx THICKNESS) (quotient (- h value-h) 2) value-w value-h #t)) + (MoveWindow slider-hwnd (->screen dx) 0 + (->screen THICKNESS) (->screen h) #t) + (MoveWindow value-hwnd (->screen (+ dx THICKNESS)) (->screen (quotient (- h value-h) 2)) + (->screen value-w) (->screen value-h) #t)) (let ([dy (quotient (- h THICKNESS value-h) 2)]) - (MoveWindow slider-hwnd 0 dy w THICKNESS #t) - (MoveWindow value-hwnd (quotient (- w value-w) 2) (+ dy THICKNESS) value-w value-h #t)))))) + (MoveWindow slider-hwnd 0 (->screen dy) + (->screen w) (->screen THICKNESS) #t) + (MoveWindow value-hwnd (->screen (quotient (- w value-w) 2)) (->screen (+ dy THICKNESS)) + (->screen value-w) (->screen value-h) #t)))))) (define/override (control-scrolled) (when value-hwnd diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/tab-panel.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/tab-panel.rkt index df9e25144e..6c3458222b 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/tab-panel.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/tab-panel.rkt @@ -65,7 +65,7 @@ "PLTTabPanel" #f (bitwise-ior WS_CHILD WS_VISIBLE) - 0 0 w h + 0 0 (->screen w) (->screen h) hwnd #f hInstance @@ -111,7 +111,9 @@ (define/override (set-size x y w h) (super set-size x y w h) (unless (or (= w -1) (= h -1)) - (MoveWindow client-hwnd 1 (+ tab-height 2) (- w 4) (- h tab-height 6) #t))) + (MoveWindow client-hwnd (->screen 1) (->screen (+ tab-height 2)) + (->screen (- w 4)) (->screen (- h tab-height 6)) + #t))) (define/override (is-command? cmd) (= cmd -551)) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/utils.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/utils.rkt index 4b4b6060c7..5443f79dc7 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/utils.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/utils.rkt @@ -3,7 +3,9 @@ ffi/unsafe/define ffi/unsafe/alloc "../common/utils.rkt" - "types.rkt") + "../../lock.rkt" + "types.rkt" + "const.rkt") (provide define-mz @@ -43,7 +45,10 @@ ModifyMenuW RemoveMenu SelectObject - WideCharToMultiByte)) + WideCharToMultiByte + GetDeviceCaps + ->screen + ->normal)) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -156,3 +161,31 @@ (define-kernel32 WideCharToMultiByte (_wfun _UINT _DWORD _pointer _int _pointer _int _pointer _pointer -> _int)) +;; ---------------------------------------- + +(define-gdi32 GetDeviceCaps (_wfun _HDC _int -> _int)) + +(define screen-dpi + (atomically + (let ([hdc (GetDC #f)]) + (begin0 + (GetDeviceCaps hdc LOGPIXELSX) + (ReleaseDC #f hdc))))) + +;; Convert a normalized (conceptually 96-dpi) measure into a screen measure +(define (->screen x) + (and x + (if (= screen-dpi 96) + x + (if (exact? x) + (ceiling (/ (* x screen-dpi) 96)) + (/ (* x screen-dpi) 96))))) + +;; Convert a screen measure to a normalize (conceptually 96-dpi) measure +(define (->normal x) + (and x + (if (= screen-dpi 96) + x + (if (exact? x) + (floor (/ (* x 96) screen-dpi)) + (/ (* x 96) screen-dpi))))) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/window.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/window.rkt index 5326afe531..57f1ce18fe 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/window.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/window.rkt @@ -307,18 +307,18 @@ (define/public (get-x) (let ([r (GetWindowRect hwnd)] [pr (GetWindowRect (send parent get-content-hwnd))]) - (- (RECT-left r) (RECT-left pr)))) + (->normal (- (RECT-left r) (RECT-left pr))))) (define/public (get-y) (let ([r (GetWindowRect hwnd)] [pr (GetWindowRect (send parent get-content-hwnd))]) - (- (RECT-top r) (RECT-top pr)))) + (->normal (- (RECT-top r) (RECT-top pr))))) (define/public (get-width) (let ([r (GetWindowRect hwnd)]) - (- (RECT-right r) (RECT-left r)))) + (->normal (- (RECT-right r) (RECT-left r))))) (define/public (get-height) (let ([r (GetWindowRect hwnd)]) - (- (RECT-bottom r) (RECT-top r)))) + (->normal (- (RECT-bottom r) (RECT-top r))))) (define/public (notify-child-extent x y) (void)) @@ -330,13 +330,13 @@ (= w -1) (= h -1)) (let ([r (GetWindowRect hwnd)]) - (values (or x (RECT-left r)) - (or y (RECT-top r)) - (if (= w -1) (- (RECT-right r) (RECT-left r)) w) - (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h))) + (values (or x (->normal (RECT-left r))) + (or y (->normal (RECT-top r))) + (if (= w -1) (->normal (- (RECT-right r) (RECT-left r))) w) + (if (= h -1) (->normal (- (RECT-bottom r) (RECT-top r))) h))) (values x y w h))]) (when parent (send parent notify-child-extent (+ x w) (+ y h))) - (MoveWindow hwnd x y w h #t)) + (MoveWindow hwnd (->screen x) (->screen y) (->screen w) (->screen h) #t)) (unless (and (= w -1) (= h -1)) (on-resized)) (queue-on-size) @@ -433,23 +433,23 @@ (define/public (screen-to-client x y) (internal-screen-to-client x y)) (define/public (internal-screen-to-client x y) - (let ([p (make-POINT (unbox x) (unbox y))]) + (let ([p (make-POINT (->screen (unbox x)) (->screen (unbox y)))]) (ScreenToClient (get-client-hwnd) p) - (set-box! x (POINT-x p)) - (set-box! y (POINT-y p)))) + (set-box! x (->normal (POINT-x p))) + (set-box! y (->normal (POINT-y p))))) (define/public (client-to-screen x y) (internal-client-to-screen x y)) (define/public (internal-client-to-screen x y) - (let ([p (make-POINT (unbox x) (unbox y))]) + (let ([p (make-POINT (->screen (unbox x)) (->screen (unbox y)))]) (ClientToScreen (get-client-hwnd) p) - (set-box! x (POINT-x p)) - (set-box! y (POINT-y p)))) + (set-box! x (->normal (POINT-x p))) + (set-box! y (->normal (POINT-y p))))) (define/public (warp-pointer x y) (define xb (box x)) (define yb (box y)) (client-to-screen xb yb) - (void (SetCursorPos (unbox xb) (unbox yb)))) + (void (SetCursorPos (->screen (unbox xb)) (->screen (unbox yb))))) (define/public (in-content? p) (ScreenToClient (get-client-hwnd) p) @@ -477,13 +477,13 @@ (define/public (get-client-size w h) (let ([r (GetClientRect (get-client-hwnd))]) - (set-box! w (- (RECT-right r) (RECT-left r))) - (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (set-box! w (->normal (- (RECT-right r) (RECT-left r)))) + (set-box! h (->normal (- (RECT-bottom r) (RECT-top r)))))) (define/public (get-size w h) (let ([r (GetWindowRect (get-client-hwnd))]) - (set-box! w (- (RECT-right r) (RECT-left r))) - (set-box! h (- (RECT-bottom r) (RECT-top r))))) + (set-box! w (->normal (- (RECT-right r) (RECT-left r)))) + (set-box! h (->normal (- (RECT-bottom r) (RECT-top r)))))) (define cursor-handle #f) (define/public (set-cursor c) @@ -586,7 +586,7 @@ [(= msg WM_MOUSELEAVE) (let ([p (make-POINT 0 0)]) (let ([f (and (GetCursorPos p) - (location->window (POINT-x p) (POINT-y p)))]) + (location->window* (POINT-x p) (POINT-y p)))]) (unless (and (eq? f (get-top-frame)) (send f in-content? p)) (do-mouse w msg #f 'leave wParam lParam)))) @@ -636,7 +636,7 @@ [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) (let ([make-e (lambda (type) - (define-values (mx my) (adjust-event-position x y)) + (define-values (mx my) (adjust-event-position (->normal x) (->normal y))) (new mouse-event% [event-type type] [left-down (case type @@ -836,7 +836,7 @@ (unless default-control-font (set! default-control-font (make-object font% - (get-theme-font-size) + (->normal (get-theme-font-size)) (logfont->pango-family (get-theme-logfont)) 'system @@ -850,7 +850,8 @@ (define (queue-window-refresh-event win thunk) (queue-refresh-event (send win get-eventspace) thunk)) -(define (location->window x y) +;; arguments in screen coordinates +(define (location->window* x y) (let ([hwnd (WindowFromPoint (make-POINT x y))]) (let loop ([hwnd hwnd]) (and hwnd @@ -858,6 +859,9 @@ (and wx (send wx get-top-frame))) (loop (GetParent hwnd))))))) +(define (location->window x y) + (location->window* (->screen x) (->screen y))) + (define (flush-display) (atomically (pre-event-sync #t))) diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt index ba907c204f..c0a9b8299e 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt @@ -104,8 +104,7 @@ (define already-trying? #f) (define was-bad? #f) ; hack around min-frame-size limitations - (define last-width -1) - (define last-height -1) + (define tried-sizes #hash()) ;; pointer to panel in the frame for use in on-size (define panel #f) @@ -352,19 +351,19 @@ [(and (= new-width correct-w) (= new-height correct-h)) ;; Good size; do panel (set! was-bad? #f) + (set! tried-sizes #hash()) (enforce-size min-w min-h (if sx? -1 min-w) (if sy? -1 min-h) 1 1) (set-panel-size)] - [(and (= last-width correct-w) (= last-height correct-h) + [(and (hash-ref tried-sizes (cons correct-w correct-h) #f) was-bad?) ;; We give up; do panel (set-panel-size)] [else ;; Too large/small; try to fix it, but give up after a while (set! was-bad? #t) - (set! last-width correct-w) - (set! last-height correct-h) + (set! tried-sizes (hash-set tried-sizes (cons correct-w correct-h) #t)) (set! already-trying? #t) (enforce-size -1 -1 -1 -1 1 1) (set-size #f #f correct-w correct-h) diff --git a/racket/src/worksp/gracket/gracket.manifest b/racket/src/worksp/gracket/gracket.manifest index 5ead5ea419..9214662e04 100644 --- a/racket/src/worksp/gracket/gracket.manifest +++ b/racket/src/worksp/gracket/gracket.manifest @@ -1,4 +1,4 @@ - + @@ -19,4 +19,9 @@ + + + true + + diff --git a/racket/src/worksp/racket/racket.manifest b/racket/src/worksp/racket/racket.manifest index 5ead5ea419..9214662e04 100644 --- a/racket/src/worksp/racket/racket.manifest +++ b/racket/src/worksp/racket/racket.manifest @@ -1,4 +1,4 @@ - + @@ -19,4 +19,9 @@ + + + true + +