414 lines
15 KiB
Racket
414 lines
15 KiB
Racket
(module wxlitem racket/base
|
|
(require racket/class
|
|
racket/file
|
|
(only-in racket/base remq)
|
|
racket/snip/private/prefs
|
|
(prefix-in wx: "kernel.rkt")
|
|
"lock.rkt"
|
|
"helper.rkt"
|
|
"const.rkt"
|
|
"wx.rkt"
|
|
"check.rkt"
|
|
"wxwindow.rkt"
|
|
"wxitem.rkt"
|
|
"wxpanel.rkt")
|
|
|
|
(provide (protect-out 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-enter-leave-events #t)
|
|
(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 x-margin 0) (send l y-margin 0)
|
|
(send l skip-enter-leave-events #t)
|
|
(send l skip-subwindow-events? #t)
|
|
l)))
|
|
|
|
(define (filter-style style)
|
|
(remq 'deleted style))
|
|
|
|
(define-syntax-rule (bounce c (m . args) ...)
|
|
(begin
|
|
(define/public m (lambda args (send c m . args)))
|
|
...))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define wx-label-panel%
|
|
(class wx-control-horizontal-panel%
|
|
(init proxy parent label style font halign valign)
|
|
(inherit area-parent skip-enter-leave-events set-event-positions-wrt)
|
|
(define c #f)
|
|
|
|
(define/override (enable on?) (if c (send c enable on?) (void)))
|
|
(define/override (is-enabled?) (if c (send c is-enabled?) #t))
|
|
(define/override (is-window-enabled?) (if c (send c is-window-enabled?) #t))
|
|
|
|
(super-make-object #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
|
|
(skip-enter-leave-events #t)
|
|
(unless (memq 'deleted style)
|
|
(send (area-parent) add-child this))
|
|
(define horiz? (is-horiz? style parent))
|
|
(define p (make-sub horiz? proxy this (if horiz? 'left halign) 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/override (client-to-screen x y)
|
|
(if c
|
|
(send c client-to-screen x y)
|
|
(super client-to-screen x y)))
|
|
(define/override (screen-to-client x y)
|
|
(if c
|
|
(send c screen-to-client x y)
|
|
(super screen-to-client x y)))
|
|
|
|
(define/public (get-p) p)
|
|
(define/public (set-c v sx? sy?)
|
|
(set! c v)
|
|
(set-event-positions-wrt c)
|
|
(when l (send l set-event-positions-wrt c))
|
|
(when p (send p set-event-positions-wrt c))
|
|
(send c stretchable-in-x sx?)
|
|
(send c stretchable-in-y sy?)
|
|
(send c skip-subwindow-events? #t))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define wx-internal-choice%
|
|
(class (make-window-glue% (make-simple-control% wx:choice% 0 0))
|
|
(init 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?))))])
|
|
(super-make-object 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-make-object proxy parent label style font 'left '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 #t #f)
|
|
|
|
(bounce
|
|
c
|
|
(set-selection i)
|
|
(get-selection)
|
|
(number)
|
|
(clear)
|
|
(append lbl)
|
|
(delete i))
|
|
|
|
(stretchable-in-y #f)
|
|
(stretchable-in-x #f)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define list-box-wheel-step #f)
|
|
|
|
(define wx-internal-list-box%
|
|
(make-window-glue%
|
|
(class (make-control% wx:list-box% 0 0 #t #t)
|
|
(init parent cb label kind x y w h choices style font
|
|
label-font columns column-order)
|
|
(inherit get-first-item
|
|
set-first-visible-item
|
|
number-of-visible-items)
|
|
(private*
|
|
[scroll (lambda (dir)
|
|
(unless list-box-wheel-step
|
|
(set! list-box-wheel-step (get-preference* '|GRacket: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 (* (min list-box-wheel-step (number-of-visible-items)) 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)
|
|
(and (not (eq? (system-type) 'macosx)) ; scrolling is built into NSListView
|
|
(case (send e get-key-code)
|
|
[(wheel-up) (scroll -1) #t]
|
|
[(wheel-down) (scroll 1) #t]
|
|
[else #f]))))])
|
|
(super-make-object style parent cb label kind x y w h choices (cons 'deleted style) font
|
|
label-font columns column-order))))
|
|
|
|
(define wx-list-box%
|
|
(class wx-label-panel%
|
|
(init mred proxy parent cb label kind x y w h choices style font label-font columns column-order)
|
|
(inherit get-p set-c)
|
|
|
|
(super-make-object proxy parent label style font 'left '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 columns column-order))
|
|
(set-c c #t #t)
|
|
|
|
(bounce
|
|
c
|
|
(get-label-font)
|
|
(set-string i s col)
|
|
(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)
|
|
(set choices . more)
|
|
(reset)
|
|
(get-column-order)
|
|
(set-column-order l)
|
|
(set-column-label i l)
|
|
(set-column-size i w mn mx)
|
|
(get-column-size i)
|
|
(delete-column i)
|
|
(append-column l))
|
|
(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%
|
|
(class (make-simple-control% wx:radio-box% 0 0)
|
|
(init 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))])])
|
|
|
|
(define 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)))))])
|
|
|
|
(super-make-object style parent cb label x y w h choices major (cons 'deleted style) font)
|
|
|
|
(define 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-make-object proxy parent label style font 'left '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 #t #t)
|
|
|
|
(define enable-vector (make-vector (length choices) #t))
|
|
|
|
(define/override enable
|
|
(case-lambda
|
|
[(on?) (super enable on?)]
|
|
[(i on?)
|
|
(when (< -1 i (vector-length enable-vector))
|
|
(vector-set! enable-vector i on?)
|
|
(send c enable-button i on?))]))
|
|
|
|
(define/override is-enabled?
|
|
(case-lambda
|
|
[() (super is-enabled?)]
|
|
[(which) (and (< -1 which (vector-length enable-vector))
|
|
(vector-ref enable-vector which))]))
|
|
|
|
(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%
|
|
(class (make-control% wx:gauge% 0 0 #f #f)
|
|
(init 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)])
|
|
;; # pixels per unit of value.
|
|
(define pixels-per-value 1)
|
|
(super-make-object 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-make-object proxy parent label style font 'center 'center)
|
|
|
|
(define c (make-object wx-internal-gauge% mred proxy (get-p) label range
|
|
(filter-style style) font))
|
|
(set-c c
|
|
(memq 'horizontal style)
|
|
(memq 'vertical style))
|
|
|
|
(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%
|
|
(class (make-control% wx:slider% 0 0 #f #f)
|
|
(init 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)
|
|
;; # pixels per possible setting.
|
|
(define 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.
|
|
|
|
(super-make-object 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-make-object proxy parent label style font 'center '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
|
|
(memq 'horizontal style)
|
|
(memq 'vertical style))
|
|
|
|
(bounce
|
|
c
|
|
(get-value)
|
|
(set-value v))
|
|
(let ([h? (and (memq 'horizontal style) #t)])
|
|
(stretchable-in-x h?)
|
|
(stretchable-in-y (not h?)))))
|
|
|
|
)
|