From 7dd75533793f7708aa4d0c8da1090438a12906f5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 07:53:38 -0600 Subject: [PATCH] win32: misc repairs original commit: d4f7df6eb88d235e58fc54502acfdcbeb081132c --- collects/mred/private/wx/cocoa/procs.rkt | 4 -- collects/mred/private/wx/gtk/procs.rkt | 4 -- collects/mred/private/wx/win32/button.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 4 ++ collects/mred/private/wx/win32/dc.rkt | 24 +++++++---- collects/mred/private/wx/win32/frame.rkt | 32 +++++++++++++- .../mred/private/wx/win32/group-panel.rkt | 1 + collects/mred/private/wx/win32/hbitmap.rkt | 43 +++++++++++++------ collects/mred/private/wx/win32/procs.rkt | 24 ++++++----- collects/mred/private/wx/win32/window.rkt | 3 +- 10 files changed, 96 insertions(+), 45 deletions(-) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 267be1c3..9734d1d4 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -47,8 +47,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -108,8 +106,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) (define (id-to-menu-item id) id) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #t) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index a59ced41..7c5dcfd9 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -45,8 +45,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -103,8 +101,6 @@ (define-unimplemented is-color-display?) (define (id-to-menu-item i) i) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 80901867..88a153f3 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -54,7 +54,7 @@ (when bitmap? (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP - (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM))) (set-control-font font) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index f3b6c0c3..931ba4b2 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -278,6 +278,10 @@ (send col green) (send col blue))))) + (define wants-focus? (not (memq 'no-focus style))) + (define/override (can-accept-focus?) + wants-focus?) + (define h-scroll-visible? hscroll?) (define v-scroll-visible? vscroll?) (define/public (show-scrollbars h? v?) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 3fd63e7d..efdd082b 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -13,6 +13,7 @@ ffi/unsafe/alloc) (provide dc% + win32-bitmap% do-backing-flush request-flush-delay cancel-flush-delay) @@ -23,14 +24,21 @@ (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if (not hwnd) - (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) - (atomically - (let ([hdc (GetDC hwnd)]) - (begin0 - (cairo_win32_surface_create_with_ddb hdc - CAIRO_FORMAT_RGB24 w h) - (ReleaseDC hwnd hdc)))))) + (let ([s + (if (not hwnd) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC hwnd)]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hwnd hdc)))))]) + ;; initialize bitmap to white: + (let ([cr (cairo_create s)]) + (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0) + (cairo_paint cr) + (cairo_destroy cr)) + s)) (define/override (ok?) #t) (define/override (is-color?) #t) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 6f0aa1d8..3a49cc3e 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/class + racket/draw (only-in racket/list last) ffi/unsafe "../../syntax.rkt" @@ -12,6 +13,7 @@ "theme.rkt" "window.rkt" "wndclass.rkt" + "hbitmap.rkt" "cursor.rkt") (provide frame% @@ -37,6 +39,14 @@ [ptMinTrackSize _POINT] [ptMaxTrackSize _POINT])) +(define-cstruct _ICONINFO ([fIcon _BOOL] + [xHotspot _DWORD] + [yHotspot _DWORD] + [hbmMask _HBITMAP] + [hbmColor _HBITMAP])) +(define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON) + -> (or r (failed 'CreateIconIndirect)))) + (define SPI_GETWORKAREA #x0030) (define (display-size xb yb ?) @@ -119,7 +129,7 @@ (super-new [parent #f] [hwnd (create-frame parent label w h style)] - [style (cons 'invisible style)]) + [style (cons 'deleted style)]) (define hwnd (get-hwnd)) (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) @@ -148,6 +158,9 @@ SW_SHOWMAXIMIZED SW_SHOW))) + (define/public (destroy) + (direct-show #f)) + (define/private (stdret f d) (if (is-dialog?) d f)) @@ -366,7 +379,22 @@ (define/override (is-frame?) #t) (define/public (set-icon bm mask [mode 'both]) - (void)) + (let ([hicon (CreateIconIndirect + (make-ICONINFO + #t 0 0 + (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-brush "black" 'solid) + (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send dc set-bitmap #f) + (bitmap->hbitmap bm #:b&w? #t)) + (bitmap->hbitmap bm #:mask mask)))]) + (when (or (eq? mode 'small) + (eq? mode 'both)) + (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM))) + (when (or (eq? mode 'big) + (eq? mode 'both)) + (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM))))) (def/public-unimplemented iconize) (define/public (set-title s) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 8fe5c030..3d7e7ff2 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -49,6 +49,7 @@ (super-new [callback void] [parent parent] [hwnd hwnd] + [extra-hwnds (list client-hwnd)] [style style]) (define/override (get-client-hwnd) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt index fe9aea80..b4e0952f 100644 --- a/collects/mred/private/wx/win32/hbitmap.rkt +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -11,37 +11,52 @@ (provide bitmap->hbitmap) (define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) +(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP)) (define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) -> (unless r (failed 'DeleteDC)))) -(define (bitmap->hbitmap bm) +(define (bitmap->hbitmap bm + #:mask [mask-bm #f] + #:b&w? [b&w? #f] + #:bg [bg (GetSysColor COLOR_BTNFACE)]) (let* ([w (send bm get-width)] [h (send bm get-height)] - [col (GetSysColor COLOR_BTNFACE)] + [mask-bm (or mask-bm + (send bm get-loaded-mask))] [to-frac (lambda (v) (/ v 255.0))] [screen-hdc (GetDC #f)] [hdc (CreateCompatibleDC screen-hdc)] - [hbitmap (CreateCompatibleBitmap screen-hdc w h)] + [hbitmap (if b&w? + (CreateBitmap w h 1 1 #f) + (CreateCompatibleBitmap screen-hdc w 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) (cairo_set_source_rgba cr - (to-frac (GetRValue col)) - (to-frac (GetGValue col)) - (to-frac (GetBValue col)) + (to-frac (GetRValue bg)) + (to-frac (GetGValue bg)) + (to-frac (GetBValue bg)) 1.0) (cairo_paint cr) - (let ([p (cairo_get_source cr)]) - (cairo_pattern_reference p) - (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) - (cairo_new_path cr) - (cairo_rectangle cr 0 0 w h) - (cairo_fill cr) - (cairo_set_source cr p) - (cairo_pattern_destroy p)) + (let ([mask-p (and mask-bm + (cairo_pattern_create_for_surface + (send mask-bm get-cairo-alpha-surface)))]) + (let ([p (cairo_get_source cr)]) + (cairo_pattern_reference p) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (if mask-p + (cairo_mask cr mask-p) + (begin + (cairo_new_path cr) + (cairo_rectangle cr 0 0 w h) + (cairo_fill cr))) + (when mask-p + (cairo_pattern_destroy mask-p)) + (cairo_set_source cr p) + (cairo_pattern_destroy p))) (cairo_destroy cr) (SelectObject hdc old-hbitmap) (DeleteDC hdc) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 6e191c5f..e2a4e761 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -8,6 +8,7 @@ "const.rkt" "menu-item.rkt" "frame.rkt" + "dc.rkt" racket/draw) (provide @@ -41,8 +42,6 @@ is-color-display? file-selector id-to-menu-item - get-the-x-selection - get-the-clipboard show-print-setup can-show-print-setup? get-highlight-background-color @@ -54,7 +53,11 @@ (define-unimplemented special-option-key) (define-unimplemented get-color-from-user) (define-unimplemented get-font-from-user) -(define (get-panel-background) (make-object color% "gray")) + +(define (get-panel-background) + (let ([c (GetSysColor COLOR_BTNFACE)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (define-unimplemented play-sound) (define-unimplemented find-graphical-system-path) (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) @@ -74,18 +77,17 @@ (define (flush-display) (void)) (define-unimplemented write-resource) (define-unimplemented get-resource) -(define-unimplemented bell) + +(define-user32 MessageBeep (_wfun _UINT -> _BOOL)) +(define (bell) + (void (MessageBeep MB_OK))) (define (hide-cursor) (void)) -(define-unimplemented end-busy-cursor) -(define-unimplemented is-busy?) -(define-unimplemented begin-busy-cursor) (define (get-display-depth) 32) + (define-unimplemented is-color-display?) (define-unimplemented file-selector) -(define-unimplemented get-the-x-selection) -(define-unimplemented get-the-clipboard) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) @@ -96,6 +98,8 @@ (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) -(define-unimplemented make-screen-bitmap) +(define/top (make-screen-bitmap [exact-positive-integer? w] + [exact-positive-integer? h]) + (make-object win32-bitmap% w h #f)) (define (check-for-break) #f) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 06d37e61..f7cc9df2 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -183,7 +183,7 @@ (register-child-in-parent on?) (unless on? (not-focus-child this)) (ShowWindow hwnd (if on? on-mode SW_HIDE))) - (unless (memq 'invisible style) + (unless (memq 'deleted style) (show #t)) (def/public-unimplemented on-drop-file) @@ -256,7 +256,6 @@ (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) #t)) (MoveWindow hwnd x y w h #t)) - (on-size w h) (unless (and (= w -1) (= h -1)) (on-resized)) (refresh))