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 + +