From 35703b49b9ef7bb534767b6c33b7f554a425a83e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Sep 2010 10:29:36 -0600 Subject: [PATCH] win32 theme and basic canvas --- collects/mred/private/wx/gtk/dc.rkt | 2 +- collects/mred/private/wx/platform.rkt | 2 +- collects/mred/private/wx/win32/button.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 158 ++++++++++++++++++---- collects/mred/private/wx/win32/dc.rkt | 114 ++++++++++++++++ collects/mred/private/wx/win32/procs.rkt | 3 +- collects/mred/private/wx/win32/queue.rkt | 3 +- collects/mred/private/wx/win32/theme.rkt | 78 +++++++++++ collects/mred/private/wx/win32/types.rkt | 4 + collects/mred/private/wx/win32/utils.rkt | 8 +- collects/mred/private/wx/win32/window.rkt | 32 ++++- collects/racket/draw/font-dir.rkt | 1 + 12 files changed, 366 insertions(+), 41 deletions(-) create mode 100644 collects/mred/private/wx/win32/dc.rkt create mode 100644 collects/mred/private/wx/win32/theme.rkt diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 5b223022b2..8265735ce2 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -54,7 +54,7 @@ (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if gdk-win + (if (not gdk-win) (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) (atomically (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))]) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 2507a56f95..222204a25c 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -4,7 +4,7 @@ (define-runtime-path platform-lib (case (system-type) - [() '(lib "mred/private/wx/win32/platform.rkt")] + [(#;windows) '(lib "mred/private/wx/win32/platform.rkt")] [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")] [(windows unix) '(lib "mred/private/wx/gtk/platform.rkt")])) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 478b6af469..972bc468a4 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -27,6 +27,6 @@ #f)] [style style]) - (auto-size label 50 14) + (auto-size label 40 12 12 0) (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 78456edb22..dd34e48729 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -1,32 +1,132 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + racket/draw + "../../syntax.rkt" + "../../lock.rkt" + "../common/canvas-mixin.rkt" + "../common/backing-dc.rkt" + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "window.rkt" + "dc.rkt") (provide canvas%) -(defclass canvas% window% - (def/public-unimplemented get-canvas-background) - (def/public-unimplemented set-canvas-background) - (def/public-unimplemented set-background-to-gray) - (def/public-unimplemented on-scroll) - (def/public-unimplemented set-scroll-page) - (def/public-unimplemented set-scroll-range) - (def/public-unimplemented set-scroll-pos) - (def/public-unimplemented get-scroll-page) - (def/public-unimplemented get-scroll-range) - (def/public-unimplemented get-scroll-pos) - (def/public-unimplemented scroll) - (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) - (def/public-unimplemented set-resize-corner) - (def/public-unimplemented show-scrollbars) - (def/public-unimplemented set-scrollbars) - (def/public-unimplemented get-virtual-size) - (def/public-unimplemented get-dc) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event) - (def/public-unimplemented on-paint) - (def/public-unimplemented begin-refresh-sequence) - (def/public-unimplemented end-refresh-sequence) - (super-new)) +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) +(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL)) + +(define canvas% + (canvas-mixin + (class window% + (init parent + x y w h + style + [ignored-name #f] + [gl-config #f]) + + (inherit get-win32 + get-client-size) + + (define hscroll? (memq 'hscroll style)) + (define vscroll? (memq 'vscroll style)) + + (super-new [parent parent] + [win32 + (CreateWindowExW 0 + "PLTCanvas" + #f + (bitwise-ior WS_CHILD WS_VISIBLE + (if hscroll? WS_HSCROLL 0) + (if vscroll? WS_VSCROLL 0)) + 0 0 w h + (send parent get-win32) + #f + hInstance + #f)] + [style style]) + + (define win32 (get-win32)) + + (define/override (wndproc w msg wparam lparam) + (cond + [(= msg WM_PAINT) + (let* ([ps (malloc 128)] + [hdc (BeginPaint w ps)]) + (unless (positive? paint-suspended) + (unless (do-backing-flush this dc hdc) + (queue-paint)) + (do-backing-flush this dc hdc)) + (EndPaint hdc ps)) + 0] + [else (super wndproc w msg wparam lparam)])) + + (define dc (new dc% [canvas this])) + + (define/public (get-dc) dc) + + ;; The `queue-paint' and `paint-children' methods + ;; are defined by `canvas-mixin' from ../common/canvas-mixin + (define/public (queue-paint) (void)) + (define/public (request-canvas-flush-delay) + (request-flush-delay this)) + (define/public (cancel-canvas-flush-delay req) + (cancel-flush-delay req)) + (define/public (queue-canvas-refresh-event thunk) + (queue-window-refresh-event this thunk)) + + (define/public (get-flush-window) win32) + + (define/public (begin-refresh-sequence) + (send dc suspend-flush)) + (define/public (end-refresh-sequence) + (send dc resume-flush)) + + (define/public (on-paint) (void)) + (define/override (refresh) (queue-paint)) + + (define/public (queue-backing-flush) + (void (InvalidateRect win32 #f #t))) + + (define/public (make-compatible-bitmap w h) + (send dc make-backing-bitmap w h)) + + (define paint-suspended 0) + (define/public (suspend-paint-handling) + (atomically + (set! paint-suspended (add1 paint-suspended)))) + (define/public (resume-paint-handling) + (atomically + (unless (zero? paint-suspended) + (set! paint-suspended (sub1 paint-suspended))))) + + (define/public (get-virtual-size w h) + (get-client-size w h)) + + (define transparent? (memq 'transparent style)) + (define bg-col (make-object color% "white")) + (define/public (get-canvas-background) (if transparent? + #f + bg-col)) + (define/public (set-canvas-background col) (set! bg-col col)) + + (def/public-unimplemented set-background-to-gray) + (def/public-unimplemented on-scroll) + (def/public-unimplemented set-scroll-page) + (def/public-unimplemented set-scroll-range) + (def/public-unimplemented set-scroll-pos) + (def/public-unimplemented get-scroll-page) + (def/public-unimplemented get-scroll-range) + (def/public-unimplemented get-scroll-pos) + (def/public-unimplemented scroll) + (def/public-unimplemented warp-pointer) + (def/public-unimplemented view-start) + (def/public-unimplemented set-resize-corner) + (def/public-unimplemented show-scrollbars) + (def/public-unimplemented set-scrollbars) + (def/public-unimplemented on-char) + (def/public-unimplemented on-event)))) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt new file mode 100644 index 0000000000..ab99711078 --- /dev/null +++ b/collects/mred/private/wx/win32/dc.rkt @@ -0,0 +1,114 @@ +#lang racket/base +(require ffi/unsafe + racket/class + "utils.rkt" + "types.rkt" + "../../lock.rkt" + "../common/backing-dc.rkt" + "../common/delay.rkt" + racket/draw/cairo + racket/draw/dc + racket/draw/bitmap + racket/draw/local + ffi/unsafe/alloc) + +(provide dc% + do-backing-flush + request-flush-delay + cancel-flush-delay) + +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 ReleaseDC (_wfun _HDC -> _void)) + +(define win32-bitmap% + (class bitmap% + (init w h win32) + (super-make-object (make-alternate-bitmap-kind w h)) + + (define s + (if (not win32) + (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) + (atomically + (let ([hdc (GetDC win32)]) + (begin0 + (cairo_win32_surface_create_with_ddb hdc + CAIRO_FORMAT_RGB24 w h) + (ReleaseDC hdc)))))) + + (define/override (ok?) #t) + (define/override (is-color?) #t) + (define/override (has-alpha-channel?) #f) + + (define/override (get-cairo-surface) s) + + (define/override (release-bitmap-storage) + (atomically + (cairo_surface_destroy s) + (set! s #f))))) + +(define dc% + (class backing-dc% + (init [(cnvs canvas)]) + (inherit end-delay) + (define canvas cnvs) + + (super-new) + + (define/override (make-backing-bitmap w h) + (if (send canvas get-canvas-background) + (make-object win32-bitmap% w h (send canvas get-win32)) + (super make-backing-bitmap w h))) + + (define/override (get-backing-size xb yb) + (send canvas get-client-size xb yb)) + + (define/override (get-size) + (let ([xb (box 0)] + [yb (box 0)]) + (send canvas get-virtual-size xb yb) + (values (unbox xb) (unbox yb)))) + + (define/override (queue-backing-flush) + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) + (send canvas queue-backing-flush)) + + (define/override (request-delay) + (request-flush-delay canvas)) + (define/override (cancel-delay req) + (cancel-flush-delay req)))) + +(define (do-backing-flush canvas dc hdc) + (send dc on-backing-flush + (lambda (bm) + (let ([w (box 0)] + [h (box 0)]) + (send canvas get-client-size w h) + (let* ([surface (cairo_win32_surface_create hdc)] + [cr (cairo_create surface)]) + (cairo_surface_destroy surface) + (let ([s (cairo_get_source cr)]) + (cairo_pattern_reference s) + (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0) + (cairo_new_path cr) + (cairo_rectangle cr 0 0 (unbox w) (unbox h)) + (cairo_fill cr) + (cairo_set_source cr s) + (cairo_pattern_destroy s)) + (cairo_destroy cr)))))) + +(define (request-flush-delay canvas) + (do-request-flush-delay + canvas + (lambda (gtk) + (send canvas suspend-paint-handling)) + (lambda (gtk) + (send canvas resume-paint-handling)))) + +(define (cancel-flush-delay req) + (when req + (do-cancel-flush-delay + req + (lambda (canvas) + (send canvas resume-paint-handling))))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 0a32a3524a..5e785901a0 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class "../../syntax.rkt" + "theme.rkt" racket/draw) (provide @@ -57,7 +58,7 @@ (define-unimplemented file-creator-and-type) (define-unimplemented run-printout) (define (get-double-click-time) 500) -(define (get-control-font-size) 10) +(define (get-control-font-size) (get-theme-font-size)) (define-unimplemented cancel-quit) (define-unimplemented fill-private-color) (define-unimplemented flush-display) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index ca292ea892..229c6aff8c 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -11,6 +11,7 @@ ;; from common/queue: current-eventspace queue-event + queue-refresh-event yield) ;; ------------------------------------------------------------ @@ -37,7 +38,7 @@ (define msg (malloc _MSG 'raw)) (define (events-ready?) - (GetQueueStatus QS_ALLINPUT)) + (not (zero? (GetQueueStatus QS_ALLINPUT)))) (define (install-wakeup fds) (pre-event-sync #t) diff --git a/collects/mred/private/wx/win32/theme.rkt b/collects/mred/private/wx/win32/theme.rkt new file mode 100644 index 0000000000..70b6f79ff9 --- /dev/null +++ b/collects/mred/private/wx/win32/theme.rkt @@ -0,0 +1,78 @@ +#lang racket/base +(require ffi/unsafe + "utils.ss" + "const.ss" + "types.ss") + +(provide get-theme-logfont + get-theme-font-face + get-theme-font-size + _LOGFONT-pointer) + +(define _HTHEME (_cpointer 'HTHEME)) + +(define-cstruct _FaceName1 + ([c1 _uint16] + [c2 _uint16] + [c3 _uint16] + [c4 _uint16] + [c5 _uint16] + [c6 _uint16] + [c7 _uint16] + [c8 _uint16])) + +(define-cstruct _FaceName + ([f1 _FaceName1] + [f2 _FaceName1] + [f3 _FaceName1] + [f4 _FaceName1])) + +(define-cstruct _LOGFONT + ([lfHeight _LONG] + [lfWidth _LONG] + [lfEscapement _LONG] + [lfOrientation _LONG] + [lfWeight _LONG] + [lfItalic _BYTE] + [lfUnderline _BYTE] + [lfStrikeOut _BYTE] + [lfCharSet _BYTE] + [lfOutPrecision _BYTE] + [lfClipPrecision _BYTE] + [lfQuality _BYTE] + [lfPitchAndFamily _BYTE] + [lfFaceName _FaceName])) ; 32 of them + +(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)) +(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT) + -> (when (negative? r) + (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))) +(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONT)) + -> (r : _HRESULT) + -> (if (negative? r) + (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r)) + f))) + +(define BP_PUSHBUTTON 1) +(define PBS_NORMAL 1) +(define TMT_FONT 210) +(define TMT_BODYFONT 809) + +(define TMT_MSGBOXFONT 805) + +(define theme-logfont (GetThemeSysFont #f TMT_MSGBOXFONT)) + +(define (get-theme-logfont) + theme-logfont) + +(define (get-theme-font-face) + (cast (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16)) + +(define (get-theme-font-size) + (abs (LOGFONT-lfHeight theme-logfont))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 4628de51dd..3f19d936f7 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -12,6 +12,7 @@ _UINT _BYTE _LONG + _HRESULT _HINSTANCE _HWND @@ -20,6 +21,7 @@ _HCURSOR _HBRUSH _HDC + _HFONT _COLORREF @@ -41,6 +43,7 @@ (define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) (define _UINT _uint) (define _BYTE _uint8) +(define _HRESULT _int32) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -49,6 +52,7 @@ (define _HCURSOR (_cpointer/null 'HCURSOR)) (define _HBRUSH (_cpointer/null 'HBRUSH)) (define _HDC (_cpointer/null 'HDC)) +(define _HFONT (_cpointer/null 'HFONT)) (define _COLORREF _DWORD) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index efa9980fcf..074f2068b9 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -3,15 +3,21 @@ ffi/unsafe/define "../common/utils.rkt") -(provide define-user32 +(provide define-gdi32 + define-user32 define-kernel32 define-comctl32 + define-uxtheme define-mz) +(define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define uxtheme-lib (ffi-lib "uxtheme.dll")) +(define-ffi-definer define-gdi32 gdi32-lib) (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-uxtheme uxtheme-lib) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index bd45754d63..aa97a4cb07 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -5,11 +5,14 @@ "../../syntax.rkt" "utils.rkt" "types.rkt" + "const.rkt" "wndclass.rkt" - "queue.rkt") + "queue.rkt" + "theme.rkt") (provide window% queue-window-event + queue-window-refresh-event CreateWindowExW GetWindowRect) @@ -24,6 +27,10 @@ (define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) (define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) +(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) + +(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) + (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL)) (define-user32 ShowWindow (_wfun _HWND _int -> _BOOL)) @@ -33,9 +40,11 @@ (define-user32 GetDialogBaseUnits (_fun -> _LONG)) (define measure-dc #f) +(define theme-hfont #f) + (define-values (dlu-x dlu-y) (let ([v (GetDialogBaseUnits)]) - (values (* 1/4 (bitwise-and v #xFF)) + (values (* 1/4 (bitwise-and v #xFFFF)) (* 1/8 (arithmetic-shift v -16))))) (defclass window% object% @@ -88,6 +97,8 @@ (def/public-unimplemented set-phantom-size) + (define/public (paint-children) (void)) + (define/public (get-x) (let ([r (GetWindowRect win32)]) (- (RECT-left r) (send parent get-x)))) @@ -119,7 +130,10 @@ (define/public (move x y) (set-size x y -1 -1)) - (define/public (auto-size label min-w min-h) + (define/public (auto-size label min-w min-h dw dh) + (unless theme-hfont + (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) + (SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -129,8 +143,8 @@ (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)] [(->int) (lambda (v) (inexact->exact (floor v)))]) (set-size -11111 -11111 - (max (->int w) (->int (* dlu-x min-w))) - (max (->int h) (->int (* dlu-y min-h)))))) + (max (->int (+ w dw)) (->int (* dlu-x min-w))) + (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) (def/public-unimplemented popup-menu) (def/public-unimplemented center) @@ -140,7 +154,10 @@ (def/public-unimplemented refresh) (def/public-unimplemented screen-to-client) (def/public-unimplemented client-to-screen) - (def/public-unimplemented drag-accept-files) + + (define/public (drag-accept-files on?) + (void)) + (def/public-unimplemented enable) (def/public-unimplemented get-position) @@ -160,3 +177,6 @@ (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) + +(define (queue-window-refresh-event win thunk) + (queue-refresh-event (send win get-eventspace) thunk)) diff --git a/collects/racket/draw/font-dir.rkt b/collects/racket/draw/font-dir.rkt index 64e2a8178b..69aa089778 100644 --- a/collects/racket/draw/font-dir.rkt +++ b/collects/racket/draw/font-dir.rkt @@ -54,6 +54,7 @@ [(script) "Chancery"] [(symbol) "Symbol"] [else (case (system-type) + [(windows) "Tahoma"] [(macosx) "Lucida Grande"] [else "Sans"])]))