From f2bad07fb82f4b966099df575cf9571f8507eb1e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 23 Sep 2010 20:35:14 -0600 Subject: [PATCH] win32: several control classes --- collects/mred/private/wx/win32/button.rkt | 95 +++++++---- collects/mred/private/wx/win32/check-box.rkt | 24 ++- collects/mred/private/wx/win32/choice.rkt | 91 +++++++++-- collects/mred/private/wx/win32/const.rkt | 8 + collects/mred/private/wx/win32/dc.rkt | 4 +- collects/mred/private/wx/win32/frame.rkt | 7 +- collects/mred/private/wx/win32/gauge.rkt | 68 ++++++-- .../mred/private/wx/win32/group-panel.rkt | 69 +++++++- collects/mred/private/wx/win32/hbitmap.rkt | 53 +++++++ collects/mred/private/wx/win32/item.rkt | 27 +++- collects/mred/private/wx/win32/list-box.rkt | 99 +++++++++--- collects/mred/private/wx/win32/menu.rkt | 23 ++- collects/mred/private/wx/win32/message.rkt | 62 +++++++- collects/mred/private/wx/win32/panel.rkt | 54 ++++--- collects/mred/private/wx/win32/procs.rkt | 6 - collects/mred/private/wx/win32/queue.rkt | 12 +- collects/mred/private/wx/win32/radio-box.rkt | 131 +++++++++++++-- collects/mred/private/wx/win32/slider.rkt | 149 +++++++++++++++++- collects/mred/private/wx/win32/types.rkt | 9 +- collects/mred/private/wx/win32/utils.rkt | 24 ++- collects/mred/private/wx/win32/window.rkt | 66 +++++--- collects/mred/private/wx/win32/wndclass.rkt | 2 +- 22 files changed, 907 insertions(+), 176 deletions(-) create mode 100644 collects/mred/private/wx/win32/hbitmap.rkt diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index e9c970cd02..4cb7e5dc07 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -1,42 +1,81 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" "../common/event.rkt" "item.rkt" "utils.rkt" "const.rkt" "window.rkt" - "wndclass.rkt") + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") -(provide button%) +(provide base-button% + button%) -(defclass button% item% - (inherit auto-size) +(define base-button% + (class item% + (inherit set-control-font auto-size get-hwnd) - (init parent cb label x y w h style font) + (init parent cb label x y w h style font) - (define callback cb) + (define callback cb) - (super-new [parent parent] - [hwnd - (CreateWindowExW 0 - "BUTTON" - label - (bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS) - 0 0 0 0 - (send parent get-hwnd) - #f - hInstance - #f)] - [style style]) + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) - (auto-size label 40 12 12 0) + (define/public (get-class) "BUTTON") + (define/public (get-flags) BS_PUSHBUTTON) + + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + + (set-control-font font) + + (define/public (auto-size-button label) + (cond + [bitmap? + (auto-size label 0 0 4 4)] + [else + (auto-size label 40 12 12 0)])) + (auto-size-button label) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'button] + [time-stamp (current-milliseconds)]))))) + + (def/public-unimplemented set-border))) + +(define button% + (class base-button% + (super-new))) - (define/public (do-command) - (queue-window-event this (lambda () - (callback this - (new control-event% - [event-type 'button] - [time-stamp (current-milliseconds)]))))) - (def/public-unimplemented set-border)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 2479deacf0..1cf398dce9 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -1,11 +1,21 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "item.rkt") +#lang racket/base +(require racket/class + "../../syntax.rkt" + "button.rkt" + "item.rkt" + "const.rkt") (provide check-box%) -(defclass check-box% item% +(defclass check-box% base-button% + (inherit auto-size) + + (super-new) + + (define/override (get-flags) (bitwise-ior BS_AUTOCHECKBOX)) + + (define/override (auto-size-button label) + (auto-size label 0 0 20 0)) + (def/public-unimplemented set-value) - (def/public-unimplemented get-value) - (super-new)) + (def/public-unimplemented get-value)) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 935a35b070..075501ad82 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -1,14 +1,85 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide choice%) -(defclass choice% item% - (def/public-unimplemented set-selection) - (def/public-unimplemented get-selection) - (def/public-unimplemented number) - (def/public-unimplemented clear) - (def/public-unimplemented append) - (super-new)) +(define CBS_DROPDOWNLIST #x0003) +(define CB_INSERTSTRING #x014A) +(define CB_SETCURSEL #x014E) +(define CB_GETCURSEL #x0147) +(define CBN_SELENDOK 9) + +(define choice% + (class item% + (init parent cb label + x y w h + choices style font) + (inherit auto-size set-control-font + set-size) + + (define callback cb) + + (define hwnd + (CreateWindowExW 0 + "COMBOBOX" + label + (bitwise-ior WS_CHILD CBS_DROPDOWNLIST + WS_HSCROLL WS_VSCROLL + WS_BORDER WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define num-choices (length choices)) + + (for ([s (in-list choices)] + [i (in-naturals)]) + (SendMessageW/str hwnd CB_INSERTSTRING i s)) + + (SendMessageW hwnd CB_SETCURSEL 0 0) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + ;; setting the choice height somehow sets the + ;; popup-menu size, not the control that you see + (auto-size choices 0 0 40 0 + (lambda (w h) + (set-size -11111 -11111 w (* h 8)))) + + (define/override (is-command? cmd) + (= cmd CBN_SELENDOK)) + + (define/public (do-command control-hwnd) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'choice] + [time-stamp (current-milliseconds)]))))) + + + (define/public (set-selection i) + (SendMessageW hwnd CB_SETCURSEL i 0)) + + (define/public (get-selection i) + (SendMessageW hwnd CB_GETCURSEL 0 0)) + + (define/public (number) num-choices) + + (def/public-unimplemented clear) + (def/public-unimplemented append))) + diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 375c738531..7104752eed 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -272,6 +272,7 @@ (define WM_PALETTECHANGED #x0311) (define WM_HOTKEY #x0312) +(define WM_USER #x0400) ;; Class styles (define CS_VREDRAW #x0001) @@ -589,3 +590,10 @@ (define MF_MENUBREAK #x00000040) (define MF_UNHILITE #x00000000) (define MF_HILITE #x00000080) + +(define BM_SETIMAGE #x00F7) +(define IMAGE_BITMAP 0) +(define BN_CLICKED 0) + +(define SW_SHOW 5) +(define SW_HIDE 0) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index 373752447d..2ddc3c9529 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -18,7 +18,7 @@ cancel-flush-delay) (define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HDC -> _int)) +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) (define win32-bitmap% (class bitmap% @@ -33,7 +33,7 @@ (begin0 (cairo_win32_surface_create_with_ddb hdc CAIRO_FORMAT_RGB24 w h) - (ReleaseDC hdc)))))) + (ReleaseDC hwnd hdc)))))) (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 9ea9351125..55e32c686d 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -5,6 +5,7 @@ "../../syntax.rkt" "../../lock.rkt" "../common/queue.rkt" + "../common/freeze.rkt" "utils.ss" "const.ss" "types.ss" @@ -93,6 +94,11 @@ (zero? (HIWORD wParam))) (queue-window-event this (lambda () (on-menu-command (LOWORD wParam)))) 0] + [(= msg WM_INITMENU) + (constrained-reply (get-eventspace) + (lambda () (on-menu-click)) + (void)) + 0] [else (super wndproc w msg wParam lParam)])) (define/public (on-close) (void)) @@ -151,7 +157,6 @@ [else 'other]))] [else #f])) - (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) diff --git a/collects/mred/private/wx/win32/gauge.rkt b/collects/mred/private/wx/win32/gauge.rkt index 9051cf182b..e3f085ac01 100644 --- a/collects/mred/private/wx/win32/gauge.rkt +++ b/collects/mred/private/wx/win32/gauge.rkt @@ -1,13 +1,63 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide gauge%) -(defclass gauge% item% - (def/public-unimplemented get-value) - (def/public-unimplemented set-value) - (def/public-unimplemented get-range) - (def/public-unimplemented set-range) - (super-new)) +(define PBS_VERTICAL #x04) +(define PBM_SETRANGE (+ WM_USER 1)) +(define PBM_SETPOS (+ WM_USER 2)) +(define PBM_GETRANGE (+ WM_USER 7));wParam = return (TRUE ? low : high). lParam = PPBRANGE or NULL +(define PBM_GETPOS (+ WM_USER 8)) + +(define gauge% + (class item% + (inherit set-size) + + (init parent + label + rng + x y w h + style + font) + + (define hwnd + (CreateWindowExW 0 + "msctls_progress32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if (memq 'vertical style) + PBS_VERTICAL + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-range rng) + + (if (memq 'horizontal style) + (set-size -11111 -11111 100 24) + (set-size -11111 -11111 24 100)) + + (define/public (get-value) + (SendMessageW hwnd PBM_GETPOS 0 0)) + (define/public (set-value v) + (void (SendMessageW hwnd PBM_SETPOS v 0))) + (define/public (get-range) + (SendMessageW hwnd PBM_GETRANGE 0 0)) + (define/public (set-range v) + (void (SendMessageW hwnd PBM_SETRANGE 0 (MAKELPARAM 0 v)))))) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index f50287c2fc..79e218cf63 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -1,9 +1,66 @@ -#lang scheme/base -(require scheme/class - "../../syntax.rkt" - "window.rkt") +#lang racket/base +(require racket/class + ffi/unsafe + "../../syntax.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "panel.rkt" + "wndclass.rkt" + "types.rkt") (provide group-panel%) -(defclass group-panel% window% - (super-new)) + +(define group-panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) + + (inherit auto-size set-control-font) + + (define hwnd + (CreateWindowExW 0 + "BUTTON" + (or label "") + (bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define client-hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD WS_VISIBLE) + 0 0 w h + hwnd + #f + hInstance + #f)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (define/override (get-client-hwnd) + client-hwnd) + + (define label-h 0) + + (set-control-font #f) + (auto-size label 0 0 0 0 + (lambda (w h) + (set! label-h h) + (set-size -11111 -11111 (+ w 10) (+ h 10)))) + + (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))))) diff --git a/collects/mred/private/wx/win32/hbitmap.rkt b/collects/mred/private/wx/win32/hbitmap.rkt new file mode 100644 index 0000000000..b8d7caf68e --- /dev/null +++ b/collects/mred/private/wx/win32/hbitmap.rkt @@ -0,0 +1,53 @@ +#lang scheme/base +(require ffi/unsafe + racket/draw/cairo + racket/draw + racket/draw/local + racket/class + "types.rkt" + "utils.rkt" + "const.rkt") + +(provide bitmap->hbitmap) + +(define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP)) +(define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC)) +(define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL) + -> (unless r (failed 'DeleteDC)))) +(define-gdi32 SelectObject (_wfun _HDC _HBITMAP -> _HBITMAP)) +(define-user32 GetDC (_wfun _HWND -> _HDC)) +(define-user32 ReleaseDC (_wfun _HWND _HDC -> _int)) + +(define (bitmap->hbitmap bm) + (let* ([w (send bm get-width)] + [h (send bm get-height)] + [col (GetSysColor COLOR_BTNFACE)] + [to-frac (lambda (v) (/ v 255.0))] + [screen-hdc (GetDC #f)] + [hdc (CreateCompatibleDC screen-hdc)] + [hbitmap (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)) + 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)) + (cairo_destroy cr) + (SelectObject hdc old-hbitmap) + (DeleteDC hdc) + hbitmap))) + + diff --git a/collects/mred/private/wx/win32/item.rkt b/collects/mred/private/wx/win32/item.rkt index c76201cd44..6aaa3475cd 100644 --- a/collects/mred/private/wx/win32/item.rkt +++ b/collects/mred/private/wx/win32/item.rkt @@ -1,12 +1,27 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "window.rkt") + "../common/event.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide item%) (defclass item% window% - (def/public-unimplemented set-label) + (inherit get-hwnd) + + (super-new) + + (define/override (gets-focus?) #t) + + (define/public (set-label s) + (SetWindowTextW (get-hwnd) s)) + (def/public-unimplemented get-label) - (def/public-unimplemented command) - (super-new)) + (def/public-unimplemented command)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index 0ea610c1ed..b03def3bff 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -1,26 +1,81 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide list-box%) -(defclass list-box% item% - (def/public-unimplemented get-label-font) - (def/public-unimplemented set-string) - (def/public-unimplemented set-first-visible-item) - (def/public-unimplemented set) - (def/public-unimplemented get-selections) - (def/public-unimplemented get-first-item) - (def/public-unimplemented number-of-visible-items) - (def/public-unimplemented number) - (def/public-unimplemented get-selection) - (def/public-unimplemented set-data) - (def/public-unimplemented get-data) - (def/public-unimplemented selected?) - (def/public-unimplemented set-selection) - (def/public-unimplemented select) - (def/public-unimplemented delete) - (def/public-unimplemented clear) - (def/public-unimplemented append) - (super-new)) +(define WS_EX_CLIENTEDGE #x00000200) + +(define LBS_NOTIFY #x0001) +(define LBS_MULTIPLESEL #x0008) +(define LBS_HASSTRINGS #x0040) +(define LBS_MULTICOLUMN #x0200) +(define LBS_WANTKEYBOARDINPUT #x0400) +(define LBS_EXTENDEDSEL #x0800) +(define LBS_DISABLENOSCROLL #x1000) + +(define LB_ADDSTRING #x0180) + +(define list-box% + (class item% + (init parent cb + label kind x y w h + choices style + font label-font) + + (inherit set-size set-control-font) + + (define hwnd + (CreateWindowExW WS_EX_CLIENTEDGE + "LISTBOX" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY + WS_VSCROLL + (if (memq 'hscroll style) WS_HSCROLL 0) + (cond + ;; Win32 sense of "multiple" and "extended" is backwards + [(memq 'extended style) LBS_MULTIPLESEL] + [(memq 'multiple style) LBS_EXTENDEDSEL] + [else 0])) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (for ([s (in-list choices)]) + (SendMessageW/str hwnd LB_ADDSTRING 0 s)) + + (super-new [parent parent] + [hwnd hwnd] + [style style]) + + (set-control-font font) + (set-size -11111 -11111 40 40) + + (def/public-unimplemented get-label-font) + (def/public-unimplemented set-string) + (def/public-unimplemented set-first-visible-item) + (def/public-unimplemented set) + (def/public-unimplemented get-selections) + (def/public-unimplemented get-first-item) + (def/public-unimplemented number-of-visible-items) + (def/public-unimplemented number) + (def/public-unimplemented get-selection) + (def/public-unimplemented set-data) + (def/public-unimplemented get-data) + (def/public-unimplemented selected?) + (def/public-unimplemented set-selection) + (def/public-unimplemented select) + (def/public-unimplemented delete) + (def/public-unimplemented clear) + (def/public-unimplemented append))) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 5e01d3ba5b..4991ab20e6 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -13,6 +13,7 @@ (define-user32 CreatePopupMenu (_wfun -> _HMENU)) (define-user32 AppendMenuW (_wfun _HMENU _UINT _pointer _string/utf-16 -> (r : _BOOL) -> (unless r (failed 'AppendMenuW)))) +(define-user32 EnableMenuItem (_wfun _HMENU _UINT _UINT -> _BOOL)) (defclass menu% object% (init lbl @@ -40,18 +41,28 @@ (def/public-unimplemented set-label) (def/public-unimplemented set-help-string) (def/public-unimplemented number) - (def/public-unimplemented enable) + + (define/public (enable id on?) + (for ([i (in-list items)] + [pos (in-naturals)]) + (when (and i (eq? id (send i id))) + (void + (EnableMenuItem hmenu pos (bitwise-ior MF_BYPOSITION + (if on? MF_ENABLED MF_GRAYED))))))) + (def/public-unimplemented check) (def/public-unimplemented checked?) (def/public-unimplemented delete-by-position) (def/public-unimplemented delete) (public [append-item append]) - (define (append-item i label help-str-or-submenu chckable?) - (let ([id (send (id-to-menu-item i) set-parent this label chckable?)]) - (atomically - (set! items (append items (list i))) - (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))) + (define (append-item id label help-str-or-submenu chckable?) + (let ([i (id-to-menu-item id)]) + (when i + (let ([id (send i set-parent this label chckable?)]) + (atomically + (set! items (append items (list i))) + (AppendMenuW hmenu (bitwise-ior MF_STRING) (cast id _long _pointer) label)))))) (define/public (append-separator) (atomically diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index cd1468e6f8..2f46975292 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -1,10 +1,60 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide message%) -(defclass message% item% - (def/public-unimplemented get-font) - (super-new)) +(define STM_SETIMAGE #x0172) + +(define SS_LEFT #x00000000) +(define SS_BITMAP #x0000000E) + +(define message% + (class item% + (inherit auto-size set-control-font get-hwnd) + + (init parent label + x y + style font) + + (define bitmap? + (and (label . is-a? . bitmap%) + (send label ok?))) + + (define/public (get-class) "STATIC") + + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + (get-class) + (if (string? label) + label + "") + (bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + SS_BITMAP + 0)) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]) + + (when bitmap? + (SendMessageW (get-hwnd) STM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + + (set-control-font font) + + (auto-size label 0 0 0 0))) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index 650dbb7d3d..8c63bc6063 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -5,29 +5,37 @@ "wndclass.rkt" "const.rkt") -(provide panel%) +(provide panel-mixin + panel%) -(defclass panel% window% - (init parent - x y w h - style - label) +(define (panel-mixin %) + (class % + (super-new) + + (define lbl-pos 'horizontal) + (define/public (get-label-position) lbl-pos) + (define/public (set-label-position pos) (set! lbl-pos pos)) + + (def/public-unimplemented on-paint) + (define/public (set-item-cursor x y) (void)) + (def/public-unimplemented get-item-cursor))) - (super-new [parent parent] - [hwnd - (CreateWindowExW 0 - "PLTPanel" - #f - (bitwise-ior WS_CHILD) - 0 0 w h - (send parent get-hwnd) - #f - hInstance - #f)] - [style style]) +(define panel% + (class (panel-mixin window%) + (init parent + x y w h + style + label) - (def/public-unimplemented get-label-position) - (def/public-unimplemented set-label-position) - (def/public-unimplemented on-paint) - (define/public (set-item-cursor x y) (void)) - (def/public-unimplemented get-item-cursor)) + (super-new [parent parent] + [hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)] + [style style]))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7be3234170..d7eb37f56a 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -90,12 +90,6 @@ (define-unimplemented show-print-setup) (define-unimplemented can-show-print-setup?) -(define-user32 GetSysColor (_wfun _int -> _DWORD)) - -(define (GetRValue v) (bitwise-and v #xFF)) -(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) -(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) - (define (get-highlight-background-color) (let ([c (GetSysColor COLOR_HIGHLIGHT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index f1f1adda34..901345d624 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -112,13 +112,11 @@ (queue-message-dequeue (send wx get-eventspace) hwnd))) ;; Not our window, so dispatch any available events - (let loop () - (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) - (when v - (TranslateMessage msg) - (DispatchMessageW msg) - (loop))))) - #f)) + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg)))) + #t)) (define check_window_event (function-ptr check-window-event _enum_proc)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 2170afd41c..2f9973e2d9 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -1,13 +1,126 @@ #lang scheme/base -(require scheme/class - "../../syntax.rkt" - "item.rkt") +(require racket/class + racket/draw + ffi/unsafe + "../../syntax.rkt" + "../../lock.rkt" + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "hbitmap.rkt" + "types.rkt") (provide radio-box%) -(defclass radio-box% item% - (def/public-unimplemented button-focus) - (def/public-unimplemented set-selection) - (def/public-unimplemented number) - (def/public-unimplemented get-selection) - (super-new)) +(define SEP 4) +(define BM_SETCHECK #x00F1) + +(define radio-box% + (class item% + (init parent cb label + x y w h + labels + val + style + font) + + (inherit auto-size set-control-font) + + (define callback cb) + (define current-value val) + + (define hwnd + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 w h + (send parent get-client-hwnd) + #f + hInstance + #f)) + + (define radio-hwnds + (let loop ([y 0] [w 0] [labels labels]) + (if (null? labels) + (begin + (MoveWindow hwnd 0 0 w y #t) + null) + (let* ([label (car labels)] + [bitmap? (and (label . is-a? . bitmap%) + (send label ok?))] + [radio-hwnd + (CreateWindowExW 0 "BUTTON" + (if (string? label) + label + "") + (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS + (if bitmap? + BS_BITMAP + 0)) + 0 0 0 0 + hwnd + #f + hInstance + #f)]) + (when bitmap? + (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP + (cast (bitmap->hbitmap label) _HBITMAP _LPARAM))) + (ShowWindow radio-hwnd SW_SHOW) + (set-control-font font radio-hwnd) + (let-values ([(w h) + (auto-size label 0 0 20 4 (lambda (w h) + (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) + (values w h)))]) + (cons radio-hwnd + (loop (+ y SEP h) (max w h) (cdr labels)))))))) + + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + + (super-new [parent parent] + [hwnd hwnd] + [extra-hwnds radio-hwnds] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (for/or ([radio-hwnd (in-list radio-hwnds)]) + (ptr-equal? a-hwnd radio-hwnd)))) + + (define/override (is-command? cmd) + (= cmd BN_CLICKED)) + + (define/public (do-command control-hwnd) + (let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)] + [pos (in-naturals)]) + (if (ptr-equal? control-hwnd radio-hwnd) + pos + i))]) + (unless (= val current-value) + (set-selection val) + (queue-window-event this (lambda () + (callback this + (new control-event% + [event-type 'radio-box] + [time-stamp (current-milliseconds)]))))))) + + + (def/public-unimplemented button-focus) + + (define/public (set-selection val) + (atomically + (unless (= val current-value) + (unless (= current-value -1) + (SendMessageW (list-ref radio-hwnds current-value) BM_SETCHECK 0 0)) + (unless (= val -1) + (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) + (set! current-value val)))) + + (define/public (get-selection) current-value) + + (define/public (number) (length radio-hwnds)))) + diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index f547ed7488..8974e65819 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -1,11 +1,148 @@ -#lang scheme/base -(require scheme/class +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe "../../syntax.rkt" - "item.rkt") + "../common/event.rkt" + "item.rkt" + "utils.rkt" + "const.rkt" + "window.rkt" + "wndclass.rkt" + "types.rkt") (provide slider%) +(define TBS_VERT #x0002) +(define TBS_HORZ #x0000) + +(define TBM_GETPOS WM_USER) +(define TBM_GETRANGEMIN (+ WM_USER 1)) +(define TBM_GETRANGEMAX (+ WM_USER 2)) +(define TBM_GETTIC (+ WM_USER 3)) +(define TBM_SETTIC (+ WM_USER 4)) +(define TBM_SETPOS (+ WM_USER 5)) +(define TBM_SETRANGE (+ WM_USER 6)) +(define TBM_SETRANGEMIN (+ WM_USER 7)) +(define TBM_SETRANGEMAX (+ WM_USER 8)) + +(define SS_CENTER #x00000001) + +(define THICKNESS 24) +(define MIN_LENGTH 100) + (defclass slider% item% - (def/public-unimplemented set-value) - (def/public-unimplemented get-value) - (super-new)) + (init parent cb + label + val lo hi + x y w + style + font) + (inherit set-control-font + auto-size) + + (define vertical? (memq 'vertical style)) + + (define panel-hwnd + (if (memq 'plain style) + #f + (CreateWindowExW 0 + "PLTPanel" + #f + (bitwise-ior WS_CHILD) + 0 0 0 0 + (send parent get-client-hwnd) + #f + hInstance + #f))) + + (define slider-hwnd + (CreateWindowExW 0 + "msctls_trackbar32" + label + (bitwise-ior WS_CHILD WS_CLIPSIBLINGS + (if vertical? + TBS_VERT + TBS_HORZ) + (if panel-hwnd + WS_VISIBLE + 0)) + 0 0 0 0 + (or panel-hwnd + (send parent get-client-hwnd)) + #f + hInstance + #f)) + + (define value-hwnd + (and panel-hwnd + (CreateWindowExW 0 + "STATIC" + (format "~s" val) + (bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE) + 0 0 0 0 + panel-hwnd + #f + hInstance + #f))) + + (define hwnd (or panel-hwnd slider-hwnd)) + + (super-new [parent parent] + [hwnd hwnd] + [extra-hwnds + (if panel-hwnd + (list slider-hwnd value-hwnd) + null)] + [style style]) + + (define/override (is-hwnd? a-hwnd) + (or (ptr-equal? hwnd a-hwnd) + (and panel-hwnd + (or (ptr-equal? slider-hwnd a-hwnd) + (ptr-equal? value-hwnd a-hwnd))))) + + (when value-hwnd + (set-control-font font value-hwnd)) + + (define value-w 0) + (define value-h 0) + + (if panel-hwnd + (auto-size (list (format "~s" lo) + (format "~s" hi)) + 0 0 0 0 (lambda (w h) + (set! value-w w) + (set! value-h h) + (if vertical? + (set-size -11111 -11111 (+ THICKNESS w) (max h MIN_LENGTH)) + (set-size -11111 -11111 (max w MIN_LENGTH) (+ THICKNESS h))))) + (if vertical? + (set-size -11111 -11111 THICKNESS MIN_LENGTH) + (set-size -11111 -11111 MIN_LENGTH THICKNESS))) + + (SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi)) + (set-value val) + + (define/override (set-size x y w h) + (super set-size x y w h) + (when panel-hwnd + (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)) + (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)))))) + + (define/override (control-scrolled) + (when value-hwnd + (let ([val (get-value)]) + (SetWindowTextW value-hwnd (format "~s" val))))) + + (define/public (set-value val) + (SendMessageW slider-hwnd TBM_SETPOS 1 val)) + + (define/public (get-value) + (SendMessageW slider-hwnd TBM_GETPOS 0 0))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index e69f7e461f..f3fb0b7d71 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -24,6 +24,7 @@ _HBRUSH _HDC _HFONT + _HBITMAP _COLORREF @@ -36,7 +37,9 @@ (struct-out MSG) _MSG _MSG-pointer HIWORD - LOWORD) + LOWORD + MAKELONG + MAKELPARAM) (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) @@ -60,6 +63,7 @@ (define _HBRUSH (_cpointer/null 'HBRUSH)) (define _HDC (_cpointer/null 'HDC)) (define _HFONT (_cpointer/null 'HFONT)) +(define _HBITMAP (_cpointer/null 'HBITMAP)) (define _COLORREF _DWORD) @@ -106,3 +110,6 @@ (define (LOWORD v) (bitwise-and v #xFFFF)) +(define (MAKELONG a b) + (bitwise-ior (arithmetic-shift b 16) a)) +(define (MAKELPARAM a b) (MAKELONG a b)) diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index f84af2c3c1..814bea15b8 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -12,7 +12,11 @@ define-mz failed - SendMessageW) + SendMessageW SendMessageW/str + GetSysColor GetRValue GetGValue GetBValue + MoveWindow + ShowWindow + SetWindowTextW) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -28,9 +32,25 @@ (define-kernel32 GetLastError (_wfun -> _DWORD)) -(define (failed w who) +(define (failed who) (error who "call failed (~s)" (GetLastError))) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) +(define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT) + #:c-id SendMessageW) +(define-user32 GetSysColor (_wfun _int -> _DWORD)) + +(define (GetRValue v) (bitwise-and v #xFF)) +(define (GetGValue v) (bitwise-and (arithmetic-shift v -8) #xFF)) +(define (GetBValue v) (bitwise-and (arithmetic-shift v -16) #xFF)) + +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'MoveWindow)))) + +(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) + + +(define-user32 SetWindowTextW (_wfun _HWND _string/utf-16 -> (r : _BOOL) + -> (unless r (failed 'SetWindowText)))) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 34a082e14d..69350ee67e 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -36,14 +36,6 @@ (define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) -(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) - -> (unless r (failed 'MoveWindow)))) - -(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) - -(define SW_SHOW 5) -(define SW_HIDE 0) - (define-cstruct _NMHDR ([hwndFrom _HWND] [idFrom _pointer] @@ -61,17 +53,23 @@ (defclass window% object% (init-field parent hwnd) - (init style) + (init style + [extra-hwnds null]) (super-new) (define eventspace (current-eventspace)) (set-hwnd-wx! hwnd this) + (for ([extra-hwnd (in-list extra-hwnds)]) + (set-hwnd-wx! extra-hwnd this)) (define/public (get-hwnd) hwnd) (define/public (get-client-hwnd) hwnd) (define/public (get-eventspace) eventspace) + + (define/public (is-hwnd? a-hwnd) + (ptr-equal? hwnd a-hwnd)) (define/public (wndproc w msg wParam lParam) (cond @@ -105,20 +103,33 @@ [(= msg WM_COMMAND) (let* ([control-hwnd (cast lParam _LPARAM _HWND)] [wx (any-hwnd->wx control-hwnd)]) - (if wx + (if (and wx (send wx is-command? (HIWORD wParam))) (begin - (send wx do-command) + (send wx do-command control-hwnd) 0) (DefWindowProcW w msg wParam lParam)))] [(= msg WM_NOTIFY) + #; (let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)] [control-hwnd (NMHDR-hwndFrom nmhdr)] [wx (any-hwnd->wx control-hwnd)]) (when wx (send wx do-command))) 0] + [(or (= msg WM_HSCROLL) + (= msg WM_VSCROLL)) + (let* ([control-hwnd (cast lParam _LPARAM _HWND)] + [wx (any-hwnd->wx control-hwnd)]) + (if wx + (begin + (send wx control-scrolled) + 0) + (DefWindowProcW w msg wParam lParam)))] [else (DefWindowProcW w msg wParam lParam)])) + (define/public (is-command? cmd) #f) + (define/public (control-scrolled) #f) + (define/public (show on?) (direct-show on?)) @@ -190,21 +201,40 @@ (define/public (move x y) (set-size x y -1 -1)) - (define/public (auto-size label min-w min-h dw dh) + (define/public (set-control-font font [hwnd hwnd]) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) + (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)) + + (define/public (auto-size label min-w min-h dw dh + [resize + (lambda (w h) (set-size -11111 -11111 w h))]) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] [font (make-object font% 8 'system)]) (send dc set-font font) (set! measure-dc dc))) - (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)] + (let-values ([(w h d a) (let loop ([label label]) + (cond + [(null? label) (values 0 0 0 0)] + [(label . is-a? . bitmap%) + (values (send label get-width) + (send label get-height) + 0 + 0)] + [(pair? label) + (let-values ([(w1 h1 d1 a1) + (loop (car label))] + [(w2 h2 d2 a2) + (loop (cdr label))]) + (values (max w1 w2) (max h1 h2) + (max d1 d1) (max a1 a2)))] + [else + (send measure-dc get-text-extent label #f #t)]))] [(->int) (lambda (v) (inexact->exact (floor v)))]) - (set-size -11111 -11111 - (max (->int (+ w dw)) (->int (* dlu-x min-w))) - (max (->int (+ h dh)) (->int (* dlu-y min-h)))))) + (resize (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) @@ -252,7 +282,7 @@ (define/public (not-focus-child v) (send parent not-focus-child v)) - (def/public-unimplemented gets-focus?) + (define/public (gets-focus?) #f) (def/public-unimplemented centre) (define/private (do-key wParam lParam is-char? is-up?) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index d06f8bad7b..e0092a26a7 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -36,7 +36,7 @@ (atomically (hash-ref all-cells (cast p _pointer _long) #f)) (let ([wx (ptr-ref p _racket)]) (and wx - (ptr-equal? hwnd (send wx get-hwnd)) + (send wx is-hwnd? hwnd) wx)))))