102 lines
2.6 KiB
Scheme
102 lines
2.6 KiB
Scheme
(module wxgroupbox mzscheme
|
|
(require mzlib/class
|
|
(prefix wx: "kernel.ss")
|
|
"lock.ss"
|
|
"wx.ss"
|
|
"const.ss"
|
|
"gdi.ss"
|
|
"helper.ss"
|
|
"wxwindow.ss"
|
|
"wxitem.ss"
|
|
"wxcanvas.ss")
|
|
|
|
(provide (protect wx-group-box%))
|
|
|
|
(define group-right-inset 4)
|
|
|
|
(define canvas-based-group-box%
|
|
(class* wx-canvas% (wx-group-box<%>)
|
|
(init mred proxy style parent label style-again _font)
|
|
|
|
(define font (or _font small-control-font))
|
|
|
|
(inherit get-dc get-client-size get-mred
|
|
set-min-width set-min-height
|
|
set-tab-focus
|
|
set-background-to-gray
|
|
is-enabled-to-root?)
|
|
|
|
(define lbl label)
|
|
|
|
(define lbl-w 0)
|
|
(define lbl-h 0)
|
|
|
|
(define/private (compute-sizes)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(w h d a) (send dc get-text-extent lbl font)])
|
|
(set! lbl-w w)
|
|
(set! lbl-h h))))
|
|
|
|
(define/override (on-char e) (void))
|
|
(define/override (on-event e) (void))
|
|
|
|
(define/override on-paint
|
|
(entry-point
|
|
(lambda ()
|
|
(let ([dc (get-dc)])
|
|
(send dc set-background bg-color)
|
|
(send dc set-font font)
|
|
(send dc clear)
|
|
(send dc set-text-foreground
|
|
(if (is-enabled-to-root?)
|
|
black-color
|
|
disabled-color))
|
|
(send dc draw-text lbl group-right-inset 0)
|
|
(send dc set-pen light-pen)
|
|
(let-values ([(w h) (my-get-client-size)]
|
|
[(tw th ta td) (send dc get-text-extent lbl)])
|
|
(send dc draw-line
|
|
1 (/ lbl-h 2)
|
|
(- group-right-inset 2) (/ lbl-h 2))
|
|
(send dc draw-line
|
|
1 (/ lbl-h 2)
|
|
1 (- h 2))
|
|
(send dc draw-line
|
|
1 (- h 2)
|
|
(- w 2) (- h 2))
|
|
(send dc draw-line
|
|
(- w 2) (- h 2)
|
|
(- w 2) (/ lbl-h 2))
|
|
(send dc draw-line
|
|
(- w 2) (/ lbl-h 2)
|
|
(min (- w 2)
|
|
(+ group-right-inset 4 tw))
|
|
(/ lbl-h 2)))))))
|
|
|
|
(define/private (my-get-client-size)
|
|
(get-two-int-values (lambda (a b) (get-client-size a b))))
|
|
|
|
(define/override (handles-key-code code alpha? meta?)
|
|
#f)
|
|
|
|
(define/public (set-label l)
|
|
(set! lbl l)
|
|
(on-paint))
|
|
|
|
(super-instantiate (mred proxy parent -1 -1 -1 -1 '(transparent) #f))
|
|
|
|
(set-background-to-gray)
|
|
|
|
(compute-sizes)
|
|
(set-min-width (inexact->exact (ceiling (+ lbl-w group-right-inset 4))))
|
|
(set-min-height (inexact->exact (ceiling (+ lbl-h 6))))
|
|
(set-tab-focus #f)))
|
|
|
|
(define wx-group-box%
|
|
(if (eq? 'unix (system-type))
|
|
canvas-based-group-box%
|
|
(class* (make-window-glue%
|
|
(make-control% wx:group-box% 0 0 #t #t)) (wx-group-box<%>)
|
|
(define/override (gets-focus?) #f)
|
|
(super-instantiate ())))))
|