diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index aeb7b56f..c06787af 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -79,6 +79,7 @@ get-choices-from-user get-color-from-user get-default-shortcut-prefix get-directory +get-display-count get-display-depth get-display-left-top-inset get-display-size diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 9c2215da..c8dbb480 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -242,6 +242,7 @@ play-sound get-display-size get-display-left-top-inset + get-display-count get-color-from-user get-font-from-user append-editor-operation-menu-items diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index d4ba2e2c..4a3e3442 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -61,6 +61,7 @@ bell display-size display-origin + display-count flush-display fill-private-color cancel-quit diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index a974d192..db4551a2 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -42,6 +42,7 @@ cancel-quit display-origin display-size + display-count bell hide-cursor get-display-depth @@ -88,31 +89,59 @@ (define (check-for-break) #f) -(define (display-origin xb yb all?) - (if all? - (atomically - (with-autorelease - (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] - [f (tell #:type _NSRect screen visibleFrame)]) - (set-box! xb (->long (NSPoint-x (NSRect-origin f))))))) +(define (display-origin xb yb all? num) + (if (or all? (positive? num)) + (unless (atomically + (with-autorelease + (let ([screens (tell NSScreen screens)]) + (if (num . < . (tell #:type _NSUInteger screens count)) + (let* ([screen (tell screens objectAtIndex: #:type _NSUInteger num)] + [f (if (zero? num) + (tell #:type _NSRect screen visibleFrame) + (tell #:type _NSRect screen frame))]) + (set-box! xb (->long (NSPoint-x (NSRect-origin f)))) + (unless (zero? num) + (let* ([screen0 (tell screens objectAtIndex: #:type _NSUInteger 0)] + [f0 (tell #:type _NSRect screen0 frame)]) + (set-box! yb (->long (- (+ (NSPoint-y (NSRect-origin f)) + (NSSize-height (NSRect-size f))) + (NSSize-height (NSRect-size f0))))))) + #t) + #f)))) + (error 'get-display-left-top-inset "no such monitor: ~v" num)) (set-box! xb 0)) - (set-box! yb (get-menu-bar-height))) + (when (zero? num) + (set-box! yb 0)) + (set-box! yb (+ (unbox yb) (get-menu-bar-height)))) -(define (display-size xb yb all?) +(define (display-size xb yb all? num) + (unless (atomically + (with-autorelease + (let ([screens (tell NSScreen screens)]) + (if (num . < . (tell #:type _NSUInteger screens count)) + (let* ([screen (tell screens objectAtIndex: #:type _NSUInteger num)] + [f (if all? + (tell #:type _NSRect screen frame) + (tell #:type _NSRect screen visibleFrame))]) + (set-box! xb (->long (NSSize-width (NSRect-size f)))) + (set-box! yb (->long (- (NSSize-height (NSRect-size f)) + (cond + [all? 0] + [(positive? num) 0] + [(tell #:type _BOOL NSMenu menuBarVisible) 0] + ;; Make result consistent when menu bar is hidden: + [else + (get-menu-bar-height)])))) + #t) + #f)))) + (error 'get-display-size "no such monitor: ~v" num))) + + +(define (display-count) (atomically (with-autorelease - (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] - [f (if all? - (tell #:type _NSRect screen frame) - (tell #:type _NSRect screen visibleFrame))]) - (set-box! xb (->long (NSSize-width (NSRect-size f)))) - (set-box! yb (->long (- (NSSize-height (NSRect-size f)) - (cond - [all? 0] - [(tell #:type _BOOL NSMenu menuBarVisible) 0] - ;; Make result consistent when menu bar is hidden: - [else - (get-menu-bar-height)])))))))) + (let ([screens (tell NSScreen screens)]) + (tell #:type _NSUInteger screens count))))) (define-appkit NSBeep (_fun -> _void)) (define (bell) (NSBeep)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index bf7c368a..5b2f44df 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -21,6 +21,7 @@ (protect-out frame% display-origin display-size + display-count location->window)) ;; ---------------------------------------- @@ -488,23 +489,29 @@ (define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) (define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void)) +(define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int)) -(define (monitor-rect num) +(define (monitor-rect who num) (let ([s (gdk_screen_get_default)] [r (make-GdkRectangle 0 0 0 0)]) + (unless (num . < . (gdk_screen_get_n_monitors s)) + (error who "no such monitor: ~v" num)) (gdk_screen_get_monitor_geometry s num r) r)) -(define (display-origin x y all?) - (let ([r (monitor-rect 0)]) - (set-box! x (GdkRectangle-x r)) - (set-box! y (GdkRectangle-y r)))) +(define (display-origin x y all? num) + (let ([r (monitor-rect 'get-display-left-top-inset num)]) + (set-box! x (- (GdkRectangle-x r))) + (set-box! y (- (GdkRectangle-y r))))) -(define (display-size w h all?) - (let ([r (monitor-rect 0)]) +(define (display-size w h all? num) + (let ([r (monitor-rect 'get-display-size num)]) (set-box! w (GdkRectangle-width r)) (set-box! h (GdkRectangle-height r)))) +(define (display-count) + (gdk_screen_get_n_monitors (gdk_screen_get_default))) + (define (location->window x y) (for/or ([f (in-hash-keys all-frames)]) (let ([fx (send f get-x)] diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 899d67c8..48e89316 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -62,6 +62,7 @@ bell display-size display-origin + display-count flush-display fill-private-color cancel-quit diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 9514fa5b..23f92210 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -48,6 +48,7 @@ bell display-size display-origin + display-count flush-display fill-private-color cancel-quit diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 35698360..20b60d9d 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -21,7 +21,8 @@ (provide (protect-out frame% display-size - display-origin)) + display-origin + display-count)) (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) (define-user32 GetActiveWindow (_wfun -> _HWND)) @@ -35,6 +36,12 @@ (define-user32 IsZoomed (_wfun _HWND -> _BOOL)) +(define-user32 EnumDisplayMonitors (_wfun _HDC + _pointer + (_wfun #:atomic? #t _pointer _HDC _RECT-pointer _pointer + -> _BOOL) + _pointer -> _BOOL)) + (define-user32 SystemParametersInfoW (_wfun _UINT _UINT _pointer _UINT -> (r : _BOOL) -> (unless r (failed 'SystemParametersInfo)))) (define-cstruct _MINMAXINFO ([ptReserved _POINT] @@ -58,27 +65,60 @@ (define SPI_GETWORKAREA #x0030) -(define (display-size xb yb all?) - (if all? - (atomically - (let ([hdc (GetDC #f)]) - (set-box! xb (GetDeviceCaps hdc HORZRES)) - (set-box! yb (GetDeviceCaps hdc VERTRES)) - (ReleaseDC #f hdc))) - (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)))))) +(define (get-all-screen-rects) + (let ([rects null]) + (EnumDisplayMonitors #f #f (lambda (mon dc r ptr) + (set! rects (cons + (list (RECT-left r) + (RECT-top r) + (RECT-right r) + (RECT-bottom r)) + rects)) + #t) + #f) + (reverse rects))) -(define (display-origin xb yb avoid-bars?) - (if 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))) - (begin - (set-box! xb 0) - (set-box! yb 0)))) +(define (display-size xb yb all? num) + (cond + [(positive? num) + (let ([rs (get-all-screen-rects)]) + (unless (num . < . (length rs)) + (error 'get-display-size "no such monitor: ~v" num)) + (let ([r (list-ref rs num)]) + (set-box! xb (- (caddr r) (car r))) + (set-box! yb (- (cadddr r) (cadr r)))))] + [all? + (atomically + (let ([hdc (GetDC #f)]) + (set-box! xb (GetDeviceCaps hdc HORZRES)) + (set-box! yb (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))))])) + +(define (display-origin xb yb avoid-bars? num) + (cond + [(positive? num) + (let ([rs (get-all-screen-rects)]) + (unless (num . < . (length rs)) + (error 'get-display-left-top-inset "no such monitor: ~v" num)) + (let ([r (list-ref rs num)]) + (set-box! xb (- (car r))) + (set-box! yb (- (cadr r)))))] + [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)))] + [else + (set-box! xb 0) + (set-box! yb 0)])) + +(define (display-count) + (length (get-all-screen-rects))) (define mouse-frame #f) @@ -391,7 +431,7 @@ [wh (box 0)] [wx (box 0)] [wy (box 0)]) - (display-size sw sh #f) + (display-size sw sh #f 0) (if wrt (begin (send wrt get-size ww wh) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 14d8b4b5..b390f410 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -62,6 +62,7 @@ bell display-size display-origin + display-count flush-display fill-private-color cancel-quit diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index 8d54cf68..eb03fb95 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -1,11 +1,10 @@ -(module wxtop mzscheme +(module wxtop racket/base (require mzlib/class mzlib/class100 - mzlib/etc mzlib/list - (prefix wx: "kernel.rkt") - (prefix wx: "wxme/editor-canvas.rkt") - (prefix wx: "wxme/editor-snip.rkt") + (prefix-in wx: "kernel.rkt") + (prefix-in wx: "wxme/editor-canvas.rkt") + (prefix-in wx: "wxme/editor-snip.rkt") "lock.rkt" "helper.rkt" "const.rkt" @@ -15,14 +14,15 @@ "wxwindow.rkt" "wxcontainer.rkt") - (provide (protect active-main-frame - set-root-menu-wx-frame!) + (provide (protect-out active-main-frame + set-root-menu-wx-frame!) get-display-size get-display-left-top-inset - (protect make-top-container% - make-top-level-window-glue% - wx-frame% - wx-dialog%)) + get-display-count + (protect-out make-top-container% + make-top-level-window-glue% + wx-frame% + wx-dialog%)) ;; Weak boxed: (define active-main-frame (make-weak-box #f)) @@ -32,19 +32,27 @@ (set! root-menu-wx-frame f)) (define get-display-size - (opt-lambda ([full-screen? #f]) + (lambda ([full-screen? #f] #:monitor [monitor 0]) + (unless (exact-nonnegative-integer? monitor) + (raise-type-error 'get-display-size "exact non-negative integer" monitor)) (let ([xb (box 0)] [yb (box 0)]) - (wx:display-size xb yb full-screen?) + (wx:display-size xb yb full-screen? monitor) (values (unbox xb) (unbox yb))))) (define get-display-left-top-inset - (opt-lambda ([advisory? #f]) + (lambda ([advisory? #f] #:monitor [monitor 0]) + (unless (exact-nonnegative-integer? monitor) + (raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor)) (let ([xb (box 0)] [yb (box 0)]) - (wx:display-origin xb yb advisory?) + (wx:display-origin xb yb advisory? monitor) (values (unbox xb) (unbox yb))))) + (define get-display-count + (lambda () + (wx:display-count))) + (define-values (left-margin top-margin init-top-x init-top-y) (let-values ([(x y) (get-display-left-top-inset #f)] [(x2 y2) (get-display-left-top-inset #t)]) @@ -55,7 +63,7 @@ (define top-x init-top-x) (define top-y init-top-y) - (define top-level-windows (make-hash-table 'weak)) + (define top-level-windows (make-weak-hasheq)) ;; make-top-container%: adds the necessary functionality to wx:frame% and ;; wx:dialog%. @@ -99,8 +107,8 @@ [parent-for-center parent] - [show-ht (make-hash-table)] - [fake-show-ht (make-hash-table)]) + [show-ht (make-hasheq)] + [fake-show-ht (make-hasheq)]) (override [enable @@ -192,17 +200,17 @@ (when perform-updates? (when pending-redraws? (force-redraw)) - (when (positive? (hash-table-count fake-show-ht)) + (when (positive? (hash-count fake-show-ht)) (let ([t fake-show-ht]) - (set! fake-show-ht (make-hash-table)) - (hash-table-for-each + (set! fake-show-ht (make-hasheq)) + (hash-for-each t (lambda (win v?) (send win really-show #t))))) - (when (positive? (hash-table-count show-ht)) + (when (positive? (hash-count show-ht)) (let ([t show-ht]) - (set! show-ht (make-hash-table)) - (hash-table-for-each + (set! show-ht (make-hasheq)) + (hash-for-each t (lambda (win v?) (send win show v?))))))])] @@ -221,7 +229,7 @@ (lambda (child show?) (if perform-updates? (send child show show?) - (hash-table-put! show-ht child show?)))] + (hash-set! show-ht child show?)))] [show-control (lambda (child on?) @@ -230,10 +238,10 @@ (child . is-a? . wx-frame%) (child . is-a? . wx-dialog%)) (begin - (hash-table-remove! fake-show-ht child) + (hash-remove! fake-show-ht child) (send child really-show on?)) (begin - (hash-table-put! fake-show-ht child #t) + (hash-set! fake-show-ht child #t) (send child fake-show on?))))] ;; force-redraw: receives a message from to redraw the @@ -353,8 +361,8 @@ (when on? (position-for-initial-show)) (if on? - (hash-table-put! top-level-windows this #t) - (hash-table-remove! top-level-windows this)) + (hash-set! top-level-windows this #t) + (hash-remove! top-level-windows this)) (as-exit ; as-exit because there's an implicit wx:yield for dialogs do-show))]) @@ -713,7 +721,7 @@ (or (send event get-control-down) (send event get-meta-down) (send event get-alt-down) - (hash-table-get function-keys (send event get-key-code) #f)) + (hash-ref function-keys (send event get-key-code) #f)) (begin (send menu-bar on-demand) (send menu-bar handle-key event))))]) diff --git a/collects/scribblings/gui/global-draw-funcs.scrbl b/collects/scribblings/gui/global-draw-funcs.scrbl index 7a168613..ddc22504 100644 --- a/collects/scribblings/gui/global-draw-funcs.scrbl +++ b/collects/scribblings/gui/global-draw-funcs.scrbl @@ -14,6 +14,12 @@ Normally, drawing is automatically flushed to the screen. Use other actions depend on updating the display.} +@defproc[(get-display-count) exact-positive-integer?]{ +Returns the number of monitors currently active. On Windows and Mac OS X, + the result can change at any time. +} + + @defproc[(get-display-depth) exact-nonnegative-integer?]{ @@ -21,36 +27,44 @@ Returns the depth of the main display (a value of 1 denotes a monochrome display } -@defproc[(get-display-left-top-inset [avoid-bars? any/c #f]) +@defproc[(get-display-left-top-inset [avoid-bars? any/c #f] + [#:monitor monitor exact-nonnegative-integer? 0]) (values exact-nonnegative-integer? exact-nonnegative-integer?)]{ When the optional argument is @racket[#f] (the default), this function - returns the offset of the main screen's origin from the - top-left of the physical screen. On Unix and Windows, the result is + returns the offset of @racket[monitor]'s origin from the + top-left of the physical monitor. For @racket[monitor] @racket[0], on Unix and Windows, the result is always @racket[0] and @racket[0]; on Mac OS X, the result is - @racket[0] and the height of the menu bar. + @racket[0] and the height of the menu bar. To position a frame + at a given @racket[monitor]'s top-left corner, use the negated results from + @racket[get-display-left-top-inset] as the frame's position. -When the optional argument is true, this function returns the amount - space at the left and top of the main screen that is occupied by the - task bar (Windows) or menu bar and dock (Mac OS X). On Unix, the - result is always @racket[0] and @racket[0]. +When the optional @racket[avoid-bars?] argument is true, for @racket[monitor] + @racket[0], @racket[get-display-left-top-inset] function returns the + amount space at the left and top of the monitor that is occupied by + the task bar (Windows) or menu bar and dock (Mac OS X). On Unix, for + monitor @racket[0], the result is always @racket[0] and @racket[0]. + For monitors other than @racket[0], @racket[avoid-bars?] has no effect. -} +If @racket[monitor] is not less than the current number of available monitors, the + @racket[exn:fail] exception is raised.} -@defproc[(get-display-size [full-screen? any/c #f]) + +@defproc[(get-display-size [full-screen? any/c #f] + [#:monitor monitor exact-nonnegative-integer? 0]) (values exact-nonnegative-integer? exact-nonnegative-integer?)]{ -@index["screen resolution"]{Gets} the physical size of the display in +@index["screen resolution"]{Gets} the physical size of the specified @racket[monitor] in pixels. On Windows, this size does not include the task bar by default. On Mac OS X, this size does not include the menu bar or dock area by default. -On Windows and Mac OS X, if the optional argument is true, then +On Windows and Mac OS X, if the optional argument is true and @racket[monitor] is @racket[0], then the task bar, menu bar, and dock area are included in the result. -Returns the screen's width and height. +If @racket[monitor] is not less than the current number of available monitors, the + @racket[exn:fail] exception is raised.} -} @defproc[(is-color-display?) boolean?]{