103 lines
2.8 KiB
Racket
103 lines
2.8 KiB
Racket
|
|
(module simple-control mzscheme
|
|
(require (prefix mred: mred)
|
|
mzlib/class
|
|
mzlib/file
|
|
mzlib/pretty
|
|
mzlib/etc
|
|
mzlib/list
|
|
"utils.ss"
|
|
"base.ss"
|
|
"feature.ss")
|
|
|
|
(define gb:make-message-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit-field w h)
|
|
(inherit get-label get-label-size draw-label)
|
|
(override*
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "message"))]
|
|
[gb-get-min-size
|
|
(lambda (dc)
|
|
(get-label-size dc))]
|
|
[draw
|
|
(lambda (dc x y . other)
|
|
(draw-label dc x y))]
|
|
[gb-get-default-class (lambda () 'message%)])
|
|
(super-new))))
|
|
|
|
(define gb:message-snip% (gb:make-message-snip%
|
|
(gb:make-text-label-snip% gb:atomic-snip%
|
|
"Message")
|
|
"gb:message"))
|
|
|
|
(register-class gb:message-snip% "gb:message")
|
|
|
|
(define gb:make-button-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit-field w h)
|
|
(inherit get-label get-label-size get-callback-names draw-label)
|
|
(private-field
|
|
[m 5])
|
|
(override*
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "button"))]
|
|
[gb-get-min-size
|
|
(lambda (dc)
|
|
(let-values ([(x y) (get-label-size dc)])
|
|
(values (+ (* 2 m) x) (+ (* 2 m) y))))]
|
|
[draw
|
|
(lambda (dc x y . other)
|
|
(send dc draw-rounded-rectangle x y w h 3)
|
|
(let-values ([(lw lh) (get-label-size dc)])
|
|
(draw-label dc
|
|
(+ (+ x m) (/ (- w lw (* 2 m)) 2))
|
|
(+ (+ y m) (/ (- h lh (* 2 m)) 2)))))]
|
|
[gb-get-default-class (lambda () 'button%)])
|
|
(super-new))))
|
|
|
|
(define gb:make-check-box-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit-field w h)
|
|
(inherit get-style get-label get-callback-names get-label-size draw-label)
|
|
(private-field
|
|
[hspace 2]
|
|
[boxsize 12])
|
|
(override*
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "checkbox"))]
|
|
[gb-get-min-size
|
|
(lambda (dc)
|
|
(let-values ([(x y) (get-label-size dc)])
|
|
(values (+ boxsize hspace x) (max boxsize y))))]
|
|
[draw
|
|
(lambda (dc x y . other)
|
|
(let-values ([(lx ly) (get-label-size dc)])
|
|
(send dc draw-rectangle x (+ y (/ (- h boxsize) 2)) boxsize boxsize)
|
|
(draw-label dc (+ x boxsize hspace) (+ y (/ (- h ly) 2)))))]
|
|
[gb-get-default-class (lambda () 'check-box%)])
|
|
(super-new))))
|
|
|
|
(define gb:button-snip% (gb:make-button-snip%
|
|
(gb:make-callback-snip%
|
|
(gb:make-text-label-snip% gb:atomic-snip%
|
|
"Button"))
|
|
"gb:button"))
|
|
|
|
(define gb:check-box-snip% (gb:make-check-box-snip%
|
|
(gb:make-callback-snip%
|
|
(gb:make-text-label-snip% gb:atomic-snip%
|
|
"Checkbox"))
|
|
"gb:checkbox"))
|
|
|
|
(register-class gb:button-snip% "gb:button")
|
|
(register-class gb:check-box-snip% "gb:checkbox")
|
|
|
|
|
|
(provide gb:message-snip%
|
|
gb:button-snip%
|
|
gb:check-box-snip%))
|