168 lines
5.9 KiB
Racket
168 lines
5.9 KiB
Racket
#lang racket/base
|
|
(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
|
|
(protect-out radio-box%))
|
|
|
|
(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
|
|
is-enabled-to-root?
|
|
set-focus)
|
|
|
|
(define callback cb)
|
|
(define current-value val)
|
|
|
|
(define hwnd
|
|
(CreateWindowExW 0
|
|
"PLTTabPanel"
|
|
#f
|
|
(bitwise-ior WS_CHILD)
|
|
0 0 w h
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f))
|
|
|
|
(define label-bitmaps null)
|
|
|
|
(define radio-hwnds
|
|
(let ([horiz? (memq 'horizontal style)])
|
|
(let loop ([y 0] [w 0] [labels labels])
|
|
(if (null? labels)
|
|
(begin
|
|
(MoveWindow hwnd 0 0 (->screen w) (->screen y) #t)
|
|
null)
|
|
(let* ([label (car labels)]
|
|
[bitmap? (label . is-a? . bitmap%)]
|
|
[radio-hwnd
|
|
(CreateWindowExW/control 0
|
|
"PLTBUTTON"
|
|
(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?
|
|
(let ([hbitmap (bitmap->hbitmap label)])
|
|
(set! label-bitmaps (cons hbitmap label-bitmaps))
|
|
(SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP
|
|
(cast hbitmap _HBITMAP _LPARAM))))
|
|
(ShowWindow radio-hwnd SW_SHOW)
|
|
(set-control-font font radio-hwnd)
|
|
(let-values ([(w1 h)
|
|
(auto-size font label 0 0 20 4
|
|
(lambda (w1 h1)
|
|
(if horiz?
|
|
(MoveWindow radio-hwnd (->screen (+ w SEP)) 0
|
|
(->screen w1) (->screen h1)
|
|
#t)
|
|
(MoveWindow radio-hwnd 0 (->screen (+ y SEP))
|
|
(->screen w1) (->screen h1)
|
|
#t))
|
|
(values w1 h1)))])
|
|
(cons radio-hwnd
|
|
(loop (if horiz? (max y h) (+ y SEP h))
|
|
(if horiz? (+ w SEP w1) (max w1 w))
|
|
(cdr labels)))))))))
|
|
|
|
(unless (= val -1)
|
|
(SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0))
|
|
|
|
(super-new [callback cb]
|
|
[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/override (do-command cmd 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)])))))))
|
|
|
|
|
|
(define focused 0)
|
|
|
|
(define/public (button-focus i)
|
|
(if (= i -1)
|
|
(min focused (length radio-hwnds))
|
|
(begin
|
|
(set! focused i)
|
|
(set-focus (list-ref radio-hwnds i)))))
|
|
|
|
(define/override (get-focus-hwnd)
|
|
(if (= focused -1)
|
|
hwnd
|
|
(list-ref radio-hwnds focused)))
|
|
|
|
(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 buttons-enabled (make-vector (length radio-hwnds) #t))
|
|
(define/public (enable-button i on?)
|
|
(unless (eq? (and on? #t) (vector-ref buttons-enabled i))
|
|
(vector-set! buttons-enabled i (and on? #t))
|
|
(when (is-enabled-to-root?)
|
|
(void (EnableWindow (list-ref radio-hwnds i) on?)))))
|
|
(define/override (internal-enable on?)
|
|
(for ([radio-hwnd (in-list radio-hwnds)]
|
|
[radio-on? (in-vector buttons-enabled)])
|
|
(void (EnableWindow radio-hwnd (and on? radio-on?)))))
|
|
|
|
(define/public (get-selection) current-value)
|
|
|
|
(define/public (number) (length radio-hwnds))))
|
|
|