suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/gui: DPI-aware on Windows

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2014-09-23 08:40:34 -06:00
parent 6f25d88957
commit a64a1cb177
30 changed files with 334 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/draw-pkgs/draw-doc/scribblings/draw/bitmap-class.scrbl
View File

@ -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.

5
pkgs/draw-pkgs/draw-doc/scribblings/draw/font-class.scrbl
View File

@ -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[(()

46
pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl
View File

@ -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.
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.
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.
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]

8
pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
View File

@ -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)

14
pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt
View File

@ -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)))

17
pkgs/gui-pkgs/gui-doc/scribblings/gui/global-draw-funcs.scrbl
View File

@ -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?)

5
pkgs/gui-pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl
View File

@ -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"].}

27
pkgs/gui-pkgs/gui-doc/scribblings/gui/win-overview.scrbl
View File

@ -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.

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

@ -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))

26
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/canvas.rkt
View File

@ -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-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)))

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/const.rkt
View File

@ -611,6 +611,8 @@
(define HORZRES 8)
(define VERTRES 10)
(define LOGPIXELSX 88)
(define LOGPIXELSY 90)
(define CBS_DROPDOWNLIST #x0003)
(define CB_INSERTSTRING #x014A)

33
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/dc.rkt
View File

@ -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))])
@ -90,11 +92,10 @@
(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)

15
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/font.rkt
View File

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

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

@ -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)))

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/gcwin.rkt
View File

@ -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)

5
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/group-panel.rkt
View File

@ -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)))))

8
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/hbitmap.rkt
View File

@ -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))

8
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/list-box.rkt
View File

@ -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)

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/menu.rkt
View File

@ -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)

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/panel.rkt
View File

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

14
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/printer-dc.rkt
View File

@ -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%))

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

@ -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))

10
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/radio-box.rkt
View File

@ -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))

12
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/slider.rkt
View File

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

6
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/tab-panel.rkt
View File

@ -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))

37
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/utils.rkt
View File

@ -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)))))

52
pkgs/gui-pkgs/gui-lib/mred/private/wx/win32/window.rkt
View File

@ -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)))

9
pkgs/gui-pkgs/gui-lib/mred/private/wxtop.rkt
View File

@ -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)

7
racket/src/worksp/gracket/gracket.manifest
View File

@ -1,4 +1,4 @@
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0" xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
<security>
<requestedPrivileges>
@ -19,4 +19,9 @@
</assemblyIdentity>
</dependentAssembly>
</dependency>
<asmv3:application>
<asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
<dpiAware>true</dpiAware>
</asmv3:windowsSettings>
</asmv3:application>
</assembly>

7
racket/src/worksp/racket/racket.manifest
View File

@ -1,4 +1,4 @@
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0" xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
<security>
<requestedPrivileges>
@ -19,4 +19,9 @@
</assemblyIdentity>
</dependentAssembly>
</dependency>
<asmv3:application>
<asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
<dpiAware>true</dpiAware>
</asmv3:windowsSettings>
</asmv3:application>
</assembly>