implement labels for radio-box%, etc.
This commit is contained in:
Matthew Flatt
parent
049e4dbdcb
commit
edd12a64b8
|
|
@ -6,6 +6,7 @@
|
|||
"lock.ss"
|
||||
"check.ss"
|
||||
"wx.ss"
|
||||
"te.rkt"
|
||||
"mrtop.ss"
|
||||
"mrcanvas.ss")
|
||||
|
||||
|
|
@ -179,21 +180,14 @@
|
|||
(as-exit (lambda () (super-init p)))))))))
|
||||
|
||||
(define get-window-text-extent
|
||||
(let ([bm #f][dc #f])
|
||||
(case-lambda
|
||||
[(string font) (get-window-text-extent string font #f)]
|
||||
[(string font combine?)
|
||||
(check-string 'get-window-text-extent string)
|
||||
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
|
||||
(unless bm
|
||||
(set! bm (make-object wx:bitmap% 2 2))
|
||||
(set! dc (make-object wx:bitmap-dc%))
|
||||
(send dc set-bitmap bm))
|
||||
(unless (send bm ok?)
|
||||
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
|
||||
(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
|
||||
(values (inexact->exact w) (inexact->exact h)))])))
|
||||
|
||||
(case-lambda
|
||||
[(string font)
|
||||
(get-window-text-extent string font #f)]
|
||||
[(string font combine?)
|
||||
(check-string 'get-window-text-extent string)
|
||||
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
|
||||
(let-values ([(w h d a) (get-window-text-extent* string font combine?)])
|
||||
(values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))]))
|
||||
|
||||
(define ugly?
|
||||
(lambda (a)
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
"helper.ss"
|
||||
"wx.ss"
|
||||
"wxitem.ss"
|
||||
"wxlitem.ss"
|
||||
"mrwindow.ss"
|
||||
"mrcontainer.ss")
|
||||
|
||||
|
|
|
|||
19
collects/mred/private/te.rkt
Normal file
19
collects/mred/private/te.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/draw)
|
||||
|
||||
(provide get-window-text-extent*)
|
||||
|
||||
(define get-window-text-extent*
|
||||
(let ([bm #f][dc #f])
|
||||
(case-lambda
|
||||
[(string font) (get-window-text-extent* string font #f)]
|
||||
[(string font combine?)
|
||||
(unless bm
|
||||
(set! bm (make-object bitmap% 2 2))
|
||||
(set! dc (make-object bitmap-dc%))
|
||||
(send dc set-bitmap bm))
|
||||
(unless (send bm ok?)
|
||||
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
|
||||
(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
|
||||
(values w h d a))])))
|
||||
|
|
@ -16,7 +16,7 @@
|
|||
|
||||
(define (panel-mixin %)
|
||||
(class %
|
||||
(define lbl-pos 'vertical)
|
||||
(define lbl-pos 'horizontal)
|
||||
(super-new)
|
||||
|
||||
(define/public (get-label-position) lbl-pos)
|
||||
|
|
|
|||
|
|
@ -65,6 +65,8 @@
|
|||
font)
|
||||
(inherit get-cocoa set-focus)
|
||||
|
||||
(define horiz? (and (memq 'horizontal style) #t))
|
||||
|
||||
(super-new [parent parent]
|
||||
[cocoa
|
||||
(let ([cocoa
|
||||
|
|
@ -76,13 +78,13 @@
|
|||
cellClass: (if (andmap string? labels)
|
||||
NSButtonCell
|
||||
MyImageButtonCell)
|
||||
numberOfRows: #:type _NSInteger (length labels)
|
||||
numberOfColumns: #:type _NSInteger 1))])
|
||||
numberOfRows: #:type _NSInteger (if horiz? 1 (length labels))
|
||||
numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))])
|
||||
(for ([label (in-list labels)]
|
||||
[i (in-naturals)])
|
||||
(let ([button (tell cocoa
|
||||
cellAtRow: #:type _NSInteger i
|
||||
column: #:type _NSInteger 0)])
|
||||
cellAtRow: #:type _NSInteger (if horiz? 0 i)
|
||||
column: #:type _NSInteger (if horiz? i 0))])
|
||||
(if (and (not (string? label))
|
||||
(send label ok?))
|
||||
(begin
|
||||
|
|
@ -112,7 +114,10 @@
|
|||
(set-focus)))
|
||||
|
||||
(define/public (set-selection i)
|
||||
(tellv (get-cocoa) selectCellAtRow: #:type _NSInteger i column: #:type _NSInteger 0))
|
||||
(tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i)
|
||||
column: #:type _NSInteger (if horiz? i 0)))
|
||||
(define/public (get-selection)
|
||||
(tell #:type _NSInteger (get-cocoa) selectedRow))
|
||||
(if horiz?
|
||||
(tell #:type _NSInteger (get-cocoa) selectedColumn)
|
||||
(tell #:type _NSInteger (get-cocoa) selectedRow)))
|
||||
(define/public (number) count))
|
||||
|
|
|
|||
|
|
@ -297,7 +297,6 @@
|
|||
(def/public-unimplemented set-phantom-size)
|
||||
(def/public-unimplemented popup-menu)
|
||||
(define/public (center a b) (void))
|
||||
(def/public-unimplemented get-text-extent)
|
||||
(def/public-unimplemented refresh)
|
||||
|
||||
(def/public-unimplemented screen-to-client)
|
||||
|
|
|
|||
|
|
@ -299,7 +299,6 @@
|
|||
(def/public-unimplemented set-phantom-size)
|
||||
(def/public-unimplemented popup-menu)
|
||||
(define/public (center a b) (void))
|
||||
(def/public-unimplemented get-text-extent)
|
||||
(define/public (refresh) (void))
|
||||
|
||||
(define/public (screen-to-client x y)
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@
|
|||
(def/public-unimplemented get-height)
|
||||
(def/public-unimplemented popup-menu)
|
||||
(def/public-unimplemented center)
|
||||
(def/public-unimplemented get-text-extent)
|
||||
(def/public-unimplemented get-parent)
|
||||
(def/public-unimplemented refresh)
|
||||
(def/public-unimplemented screen-to-client)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
(require mzlib/class
|
||||
mzlib/class100
|
||||
mzlib/etc
|
||||
mzlib/file
|
||||
(prefix wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"helper.ss"
|
||||
|
|
@ -16,12 +15,7 @@
|
|||
make-simple-control%
|
||||
wx-button%
|
||||
wx-check-box%
|
||||
wx-choice%
|
||||
wx-message%
|
||||
wx-gauge%
|
||||
wx-list-box%
|
||||
wx-radio-box%
|
||||
wx-slider%))
|
||||
wx-message%))
|
||||
|
||||
;; make-item%: creates items which are suitable for placing into
|
||||
;; containers.
|
||||
|
|
@ -246,162 +240,8 @@
|
|||
(set-value (not (get-value)))
|
||||
(command (make-object wx:control-event% 'check-box)))))])
|
||||
(sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font))))
|
||||
(define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
|
||||
(override
|
||||
[handles-key-code
|
||||
(lambda (x alpha? meta?)
|
||||
(or (memq x '(up down))
|
||||
(and alpha? (not meta?))))])
|
||||
(sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))
|
||||
|
||||
(define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font)
|
||||
(override [gets-focus? (lambda () #f)])
|
||||
(sequence (super-init mred proxy style parent label x y (cons 'deleted style) font))))
|
||||
|
||||
(define wx-gauge%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:gauge%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(parent label range style font)
|
||||
(inherit get-client-size get-width get-height set-size
|
||||
stretchable-in-x stretchable-in-y set-min-height set-min-width
|
||||
get-parent)
|
||||
(override [gets-focus? (lambda () #f)])
|
||||
(private-field
|
||||
;; # pixels per unit of value.
|
||||
[pixels-per-value 1])
|
||||
(sequence
|
||||
(super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)
|
||||
|
||||
(let-values ([(client-width client-height) (get-two-int-values
|
||||
(lambda (a b) (get-client-size a b)))])
|
||||
(let ([delta-w (- (get-width) client-width)]
|
||||
[delta-h (- (get-height) client-height)]
|
||||
[vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
|
||||
[horizontal? (memq 'horizontal style)])
|
||||
(set-min-width (if horizontal?
|
||||
(let ([cw (min const-max-gauge-length
|
||||
(* range pixels-per-value))])
|
||||
(max (if vertical-labels?
|
||||
cw
|
||||
(+ cw delta-w))
|
||||
(get-width)))
|
||||
;; client-height is the default
|
||||
;; dimension in the minor direction.
|
||||
(+ client-width delta-w)))
|
||||
(set-min-height (if horizontal?
|
||||
(+ client-height delta-h)
|
||||
(let ([ch (min const-max-gauge-length
|
||||
(* range pixels-per-value))])
|
||||
(max (if vertical-labels?
|
||||
(+ ch delta-h)
|
||||
ch)
|
||||
(get-height)))))))
|
||||
|
||||
(if (memq 'horizontal style)
|
||||
(begin
|
||||
(stretchable-in-x #t)
|
||||
(stretchable-in-y #f))
|
||||
(begin
|
||||
(stretchable-in-x #f)
|
||||
(stretchable-in-y #t)))))))
|
||||
|
||||
(define list-box-wheel-step #f)
|
||||
|
||||
(define wx-list-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:list-box%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#t #t) (parent cb label kind x y w h choices style font label-font)
|
||||
(inherit get-first-item
|
||||
set-first-visible-item)
|
||||
(private
|
||||
[scroll (lambda (dir)
|
||||
(unless list-box-wheel-step
|
||||
(set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3)))
|
||||
(unless (and (number? list-box-wheel-step)
|
||||
(exact? list-box-wheel-step)
|
||||
(integer? list-box-wheel-step)
|
||||
(<= 1 list-box-wheel-step 100))
|
||||
(set! list-box-wheel-step 3)))
|
||||
(let ([top (get-first-item)])
|
||||
(set-first-visible-item
|
||||
(max 0 (+ top (* list-box-wheel-step dir))))))])
|
||||
(override
|
||||
[handles-key-code (lambda (x alpha? meta?)
|
||||
(case x
|
||||
[(up down) #t]
|
||||
[else (and alpha? (not meta?))]))]
|
||||
[pre-on-char (lambda (w e)
|
||||
(or (super pre-on-char w e)
|
||||
(case (send e get-key-code)
|
||||
[(wheel-up) (scroll -1) #t]
|
||||
[(wheel-down) (scroll 1) #t]
|
||||
[else #f])))])
|
||||
(sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
|
||||
|
||||
(define wx-radio-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
|
||||
(inherit number orig-enable set-selection command)
|
||||
(override
|
||||
[enable
|
||||
(case-lambda
|
||||
[(on?) (super enable on?)]
|
||||
[(which on?) (when (< -1 which (number))
|
||||
(vector-set! enable-vector which (and on? #t))
|
||||
(orig-enable which on?))])]
|
||||
[is-enabled?
|
||||
(case-lambda
|
||||
[() (super is-enabled?)]
|
||||
[(which) (and (< -1 which (number))
|
||||
(vector-ref enable-vector which))])])
|
||||
|
||||
(private-field [is-vertical? (memq 'vertical style)])
|
||||
(public
|
||||
[vertical? (lambda () is-vertical?)]
|
||||
[char-to-button (lambda (i)
|
||||
(as-exit
|
||||
(lambda ()
|
||||
(set-selection i)
|
||||
(command (make-object wx:control-event% 'radio-box)))))])
|
||||
|
||||
(sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))
|
||||
|
||||
(private-field [enable-vector (make-vector (number) #t)]))))
|
||||
|
||||
(define wx-slider%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:slider%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(parent func label value min-val max-val style font)
|
||||
(inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
|
||||
get-client-size get-width get-height get-parent)
|
||||
(private-field
|
||||
;; # pixels per possible setting.
|
||||
[pixels-per-value 3])
|
||||
;; 3 is good because with horizontal sliders under Xt, with 1 or 2
|
||||
;; pixels per value, the thumb is too small to display the number,
|
||||
;; which looks bad.
|
||||
|
||||
(sequence
|
||||
(super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
|
||||
|
||||
(let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
|
||||
(get-client-size a b)))])
|
||||
(let* ([horizontal? (memq 'horizontal style)]
|
||||
[vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
|
||||
[range (+ (* pixels-per-value (add1 (- max-val min-val)))
|
||||
(cond
|
||||
[(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
|
||||
[(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
|
||||
[else 0]))])
|
||||
((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
|
||||
(max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
|
||||
(min const-max-gauge-length range)))
|
||||
(stretchable-in-x horizontal?)
|
||||
(stretchable-in-y (not horizontal?))))))))
|
||||
|
||||
)
|
||||
(sequence (super-init mred proxy style parent label x y (cons 'deleted style) font)))))
|
||||
|
||||
|
|
|
|||
370
collects/mred/private/wxlitem.rkt
Normal file
370
collects/mred/private/wxlitem.rkt
Normal file
|
|
@ -0,0 +1,370 @@
|
|||
(module wxlitem mzscheme
|
||||
(require mzlib/class
|
||||
mzlib/class100
|
||||
mzlib/file
|
||||
(only racket/base remq)
|
||||
(prefix wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"helper.ss"
|
||||
"const.ss"
|
||||
"wx.ss"
|
||||
"check.ss"
|
||||
"wxwindow.ss"
|
||||
"wxitem.ss"
|
||||
"wxpanel.ss")
|
||||
|
||||
(provide (protect wx-choice%
|
||||
wx-list-box%
|
||||
wx-radio-box%
|
||||
wx-gauge%
|
||||
wx-slider%))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (is-horiz? style parent)
|
||||
(cond
|
||||
[(memq 'vertical-label style) #f]
|
||||
[(memq 'horizontal-label style) #t]
|
||||
[else (eq? (send (send parent get-window) get-label-position) 'horizontal)]))
|
||||
|
||||
(define (make-sub horiz? proxy this ha va)
|
||||
(if horiz?
|
||||
(begin
|
||||
(send this alignment ha va)
|
||||
this)
|
||||
(let ([p (make-object wx-vertical-pane% #f proxy this null #f)])
|
||||
(send p skip-subwindow-events? #t)
|
||||
(send (send p area-parent) add-child p)
|
||||
(send p alignment ha va)
|
||||
p)))
|
||||
|
||||
(define (make-label label proxy p font)
|
||||
(and label
|
||||
(let ([l (make-object wx-message% #f proxy p label -1 -1 null font)])
|
||||
(send l skip-subwindow-events? #t)
|
||||
l)))
|
||||
|
||||
(define (filter-style style)
|
||||
(remq 'deleted style))
|
||||
|
||||
(define-syntax-rule (bounce c (m arg ...) ...)
|
||||
(begin
|
||||
(define/public m (lambda (arg ...) (send c m arg ...)))
|
||||
...))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define wx-label-panel%
|
||||
(class wx-horizontal-panel%
|
||||
(init proxy parent label style font valign)
|
||||
(inherit area-parent)
|
||||
(define c #f)
|
||||
|
||||
(define/override (enable on?) (if c (send c enable on?) (void)))
|
||||
(define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))
|
||||
|
||||
(super-init #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
|
||||
(unless (memq 'deleted style)
|
||||
(send (area-parent) add-child this))
|
||||
(define horiz? (is-horiz? style parent))
|
||||
(define p (make-sub horiz? proxy this 'left valign))
|
||||
|
||||
(define l (make-label label proxy p font))
|
||||
(define/public (set-label s) (when l (send l set-label s)))
|
||||
(define/public (get-label) (and l (send l get-label)))
|
||||
|
||||
(define/public (get-p) p)
|
||||
(define/public (set-c v)
|
||||
(set! c v)
|
||||
(send c stretchable-in-x #t)
|
||||
(send c stretchable-in-y #t)
|
||||
(send c skip-subwindow-events? #t))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define wx-internal-choice%
|
||||
(class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font)
|
||||
(override
|
||||
[handles-key-code
|
||||
(lambda (x alpha? meta?)
|
||||
(or (memq x '(up down))
|
||||
(and alpha? (not meta?))))])
|
||||
(sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font))))
|
||||
|
||||
(define wx-choice%
|
||||
(class wx-label-panel%
|
||||
(init mred proxy parent cb label x y w h choices style font)
|
||||
(inherit stretchable-in-y stretchable-in-x get-p set-c)
|
||||
|
||||
(super-init proxy parent label style font 'center)
|
||||
|
||||
(define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices
|
||||
(filter-style style) font))
|
||||
(set-c c)
|
||||
|
||||
(bounce
|
||||
c
|
||||
(set-selection i)
|
||||
(get-selection)
|
||||
(number)
|
||||
(clear)
|
||||
(append lbl))
|
||||
|
||||
(stretchable-in-y #f)
|
||||
(stretchable-in-x #f)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define list-box-wheel-step #f)
|
||||
|
||||
(define wx-internal-list-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:list-box%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#t #t) (parent cb label kind x y w h choices style font label-font)
|
||||
(inherit get-first-item
|
||||
set-first-visible-item)
|
||||
(private
|
||||
[scroll (lambda (dir)
|
||||
(unless list-box-wheel-step
|
||||
(set! list-box-wheel-step (get-preference '|MrEd:wheelStep| (lambda () 3)))
|
||||
(unless (and (number? list-box-wheel-step)
|
||||
(exact? list-box-wheel-step)
|
||||
(integer? list-box-wheel-step)
|
||||
(<= 1 list-box-wheel-step 100))
|
||||
(set! list-box-wheel-step 3)))
|
||||
(let ([top (get-first-item)])
|
||||
(set-first-visible-item
|
||||
(max 0 (+ top (* list-box-wheel-step dir))))))])
|
||||
(override
|
||||
[handles-key-code (lambda (x alpha? meta?)
|
||||
(case x
|
||||
[(up down) #t]
|
||||
[else (and alpha? (not meta?))]))]
|
||||
[pre-on-char (lambda (w e)
|
||||
(or (super pre-on-char w e)
|
||||
(case (send e get-key-code)
|
||||
[(wheel-up) (scroll -1) #t]
|
||||
[(wheel-down) (scroll 1) #t]
|
||||
[else #f])))])
|
||||
(sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
|
||||
|
||||
(define wx-list-box%
|
||||
(class wx-label-panel%
|
||||
(init mred proxy parent cb label kind x y w h choices style font label-font)
|
||||
(inherit get-p set-c)
|
||||
|
||||
(super-init proxy parent label style font 'top)
|
||||
|
||||
(define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices
|
||||
(filter-style style) font label-font))
|
||||
(set-c c)
|
||||
|
||||
(bounce
|
||||
c
|
||||
(get-label-font)
|
||||
(set-string i s)
|
||||
(set-selection i)
|
||||
(get-selection)
|
||||
(get-selections)
|
||||
(visible-range)
|
||||
(get-first-item)
|
||||
(number-of-visible-items)
|
||||
(set-first-visible-item i)
|
||||
(number)
|
||||
(get-row n)
|
||||
(set-data i v)
|
||||
(get-data i)
|
||||
(selected? i)
|
||||
(delete i)
|
||||
(clear i)
|
||||
(set choices)
|
||||
(reset))
|
||||
(define/public select
|
||||
(case-lambda
|
||||
[(i) (send c select i)]
|
||||
[(i on?) (send c select i on?)]
|
||||
[(i on? extend?) (send c select i on? extend?)]))
|
||||
(define/public append
|
||||
(case-lambda
|
||||
[(s) (send c append s)]
|
||||
[(s v) (send c append s v)]))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define wx-internal-radio-box%
|
||||
(make-window-glue%
|
||||
(class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font)
|
||||
(inherit number orig-enable set-selection command)
|
||||
(override
|
||||
[enable
|
||||
(case-lambda
|
||||
[(on?) (super enable on?)]
|
||||
[(which on?) (when (< -1 which (number))
|
||||
(vector-set! enable-vector which (and on? #t))
|
||||
(orig-enable which on?))])]
|
||||
[is-enabled?
|
||||
(case-lambda
|
||||
[() (super is-enabled?)]
|
||||
[(which) (and (< -1 which (number))
|
||||
(vector-ref enable-vector which))])])
|
||||
|
||||
(private-field [is-vertical? (memq 'vertical style)])
|
||||
(public
|
||||
[vertical? (lambda () is-vertical?)]
|
||||
[char-to-button (lambda (i)
|
||||
(as-exit
|
||||
(lambda ()
|
||||
(set-selection i)
|
||||
(command (make-object wx:control-event% 'radio-box)))))])
|
||||
|
||||
(sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font))
|
||||
|
||||
(private-field [enable-vector (make-vector (number) #t)]))))
|
||||
|
||||
(define wx-radio-box%
|
||||
(class wx-label-panel%
|
||||
(init mred proxy parent cb label x y w h choices major style font)
|
||||
(inherit stretchable-in-y stretchable-in-x get-p set-c)
|
||||
|
||||
(super-init proxy parent label style font 'center)
|
||||
|
||||
(define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices
|
||||
major (filter-style style) font))
|
||||
(set-c c)
|
||||
|
||||
(bounce
|
||||
c
|
||||
(button-focus i)
|
||||
(set-selection i)
|
||||
(get-selection))
|
||||
(stretchable-in-y #f)
|
||||
(stretchable-in-x #f)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define wx-internal-gauge%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:gauge%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(parent label range style font)
|
||||
(inherit get-client-size get-width get-height set-size
|
||||
stretchable-in-x stretchable-in-y set-min-height set-min-width
|
||||
get-parent)
|
||||
(override [gets-focus? (lambda () #f)])
|
||||
(private-field
|
||||
;; # pixels per unit of value.
|
||||
[pixels-per-value 1])
|
||||
(sequence
|
||||
(super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font)
|
||||
|
||||
(let-values ([(client-width client-height) (get-two-int-values
|
||||
(lambda (a b) (get-client-size a b)))])
|
||||
(let ([delta-w (- (get-width) client-width)]
|
||||
[delta-h (- (get-height) client-height)]
|
||||
[vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
|
||||
[horizontal? (memq 'horizontal style)])
|
||||
(set-min-width (if horizontal?
|
||||
(let ([cw (min const-max-gauge-length
|
||||
(* range pixels-per-value))])
|
||||
(max (if vertical-labels?
|
||||
cw
|
||||
(+ cw delta-w))
|
||||
(get-width)))
|
||||
;; client-height is the default
|
||||
;; dimension in the minor direction.
|
||||
(+ client-width delta-w)))
|
||||
(set-min-height (if horizontal?
|
||||
(+ client-height delta-h)
|
||||
(let ([ch (min const-max-gauge-length
|
||||
(* range pixels-per-value))])
|
||||
(max (if vertical-labels?
|
||||
(+ ch delta-h)
|
||||
ch)
|
||||
(get-height)))))))
|
||||
|
||||
(if (memq 'horizontal style)
|
||||
(begin
|
||||
(stretchable-in-x #t)
|
||||
(stretchable-in-y #f))
|
||||
(begin
|
||||
(stretchable-in-x #f)
|
||||
(stretchable-in-y #t)))))))
|
||||
|
||||
(define wx-gauge%
|
||||
(class wx-label-panel%
|
||||
(init mred proxy parent label range style font)
|
||||
(inherit stretchable-in-y stretchable-in-x get-p set-c)
|
||||
|
||||
(super-init proxy parent label style font 'center)
|
||||
|
||||
(define c (make-object wx-internal-gauge% mred proxy (get-p) label range
|
||||
(filter-style style) font))
|
||||
(set-c c)
|
||||
|
||||
(bounce
|
||||
c
|
||||
(get-range)
|
||||
(set-range rng)
|
||||
(get-value)
|
||||
(set-value v))
|
||||
(let ([h? (and (memq 'horizontal style) #t)])
|
||||
(stretchable-in-x h?)
|
||||
(stretchable-in-y (not h?)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define wx-internal-slider%
|
||||
(make-window-glue%
|
||||
(class100 (make-control% wx:slider%
|
||||
const-default-x-margin const-default-y-margin
|
||||
#f #f)
|
||||
(parent func label value min-val max-val style font)
|
||||
(inherit set-min-width set-min-height stretchable-in-x stretchable-in-y
|
||||
get-client-size get-width get-height get-parent)
|
||||
(private-field
|
||||
;; # pixels per possible setting.
|
||||
[pixels-per-value 3])
|
||||
;; 3 is good because with horizontal sliders under Xt, with 1 or 2
|
||||
;; pixels per value, the thumb is too small to display the number,
|
||||
;; which looks bad.
|
||||
|
||||
(sequence
|
||||
(super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font)
|
||||
|
||||
(let-values ([(client-w client-h) (get-two-int-values (lambda (a b)
|
||||
(get-client-size a b)))])
|
||||
(let* ([horizontal? (memq 'horizontal style)]
|
||||
[vertical-labels? (eq? (send (send (get-parent) get-window) get-label-position) 'vertical)]
|
||||
[range (+ (* pixels-per-value (add1 (- max-val min-val)))
|
||||
(cond
|
||||
[(and horizontal? (not vertical-labels?)) (- (get-width) client-w)]
|
||||
[(and (not horizontal?) vertical-labels?) (- (get-height) client-h)]
|
||||
[else 0]))])
|
||||
((if horizontal? (lambda (v) (set-min-width v)) (lambda (v) (set-min-height v)))
|
||||
(max ((if horizontal? (lambda () (get-width)) (lambda () (get-height))))
|
||||
(min const-max-gauge-length range)))
|
||||
(stretchable-in-x horizontal?)
|
||||
(stretchable-in-y (not horizontal?))))))))
|
||||
|
||||
(define wx-slider%
|
||||
(class wx-label-panel%
|
||||
(init mred proxy parent func label value min-val max-val style font)
|
||||
(inherit stretchable-in-y stretchable-in-x get-p set-c)
|
||||
|
||||
(super-init proxy parent label style font 'center)
|
||||
|
||||
(define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val
|
||||
(filter-style style) font))
|
||||
(set-c c)
|
||||
|
||||
(bounce
|
||||
c
|
||||
(get-value)
|
||||
(set-value v))
|
||||
(let ([h? (and (memq 'horizontal style) #t)])
|
||||
(stretchable-in-x h?)
|
||||
(stretchable-in-y (not h?)))))
|
||||
|
||||
)
|
||||
|
|
@ -220,7 +220,7 @@
|
|||
(set! dy (- dy (unbox ybox))))
|
||||
|
||||
;; Subtract ascent of label
|
||||
(send l get-text-extent "hi" wbox hbox ybox abox)
|
||||
(send l get-text-extent "hi" wbox hbox ybox abox font)
|
||||
(set! dy (- dy (- (unbox hbox) (unbox ybox))))
|
||||
|
||||
;; Subtract space above label
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require mzlib/class
|
||||
mzlib/class100
|
||||
(prefix wx: "kernel.ss")
|
||||
"te.rkt"
|
||||
"lock.ss"
|
||||
"helper.ss"
|
||||
"wx.ss")
|
||||
|
|
@ -39,6 +40,14 @@
|
|||
[() skip-sub-events?]
|
||||
[(skip?) (set! skip-sub-events? skip?)])])
|
||||
(public
|
||||
[get-text-extent (lambda (s wb hb db ab font)
|
||||
(let-values ([(w h d a) (get-window-text-extent* s font #t)])
|
||||
(let ([set (lambda (b v)
|
||||
(when b (set-box! b (inexact->exact (ceiling v)))))])
|
||||
(set wb w)
|
||||
(set hb h)
|
||||
(set db d)
|
||||
(set ab a))))]
|
||||
[on-active
|
||||
(lambda ()
|
||||
(let ([act? (is-enabled-to-root?)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user