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

win32: several control classes

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-23 20:35:14 -06:00
parent bc0869f43c
commit f2bad07fb8
22 changed files with 907 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
collects/mred/private/wx/win32/button.rkt
View File

@ -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
"<image>")
(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))

24
collects/mred/private/wx/win32/check-box.rkt
View File

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

91
collects/mred/private/wx/win32/choice.rkt
View File

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

8
collects/mred/private/wx/win32/const.rkt
View File

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

4
collects/mred/private/wx/win32/dc.rkt
View File

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

7
collects/mred/private/wx/win32/frame.rkt
View File

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

68
collects/mred/private/wx/win32/gauge.rkt
View File

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

69
collects/mred/private/wx/win32/group-panel.rkt
View File

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

53
collects/mred/private/wx/win32/hbitmap.rkt Normal file
View File

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

27
collects/mred/private/wx/win32/item.rkt
View File

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

99
collects/mred/private/wx/win32/list-box.rkt
View File

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

23
collects/mred/private/wx/win32/menu.rkt
View File

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

62
collects/mred/private/wx/win32/message.rkt
View File

@ -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
"<image>")
(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)))

54
collects/mred/private/wx/win32/panel.rkt
View File

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

6
collects/mred/private/wx/win32/procs.rkt
View File

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

12
collects/mred/private/wx/win32/queue.rkt
View File

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

131
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -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
"<image>")
(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))))

149
collects/mred/private/wx/win32/slider.rkt
View File

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

9
collects/mred/private/wx/win32/types.rkt
View File

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

24
collects/mred/private/wx/win32/utils.rkt
View File

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

66
collects/mred/private/wx/win32/window.rkt
View File

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

2
collects/mred/private/wx/win32/wndclass.rkt
View File

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