408 lines
14 KiB
Racket
408 lines
14 KiB
Racket
(module wxitem mzscheme
|
|
(require mzlib/class
|
|
mzlib/class100
|
|
mzlib/etc
|
|
mzlib/file
|
|
(prefix wx: "kernel.ss")
|
|
"lock.ss"
|
|
"helper.ss"
|
|
"const.ss"
|
|
"wx.ss"
|
|
"check.ss"
|
|
"wxwindow.ss")
|
|
|
|
(provide (protect make-item%
|
|
make-control%
|
|
make-simple-control%
|
|
wx-button%
|
|
wx-check-box%
|
|
wx-choice%
|
|
wx-message%
|
|
wx-gauge%
|
|
wx-list-box%
|
|
wx-radio-box%
|
|
wx-slider%))
|
|
|
|
;; make-item%: creates items which are suitable for placing into
|
|
;; containers.
|
|
;; input: item%: a wx:item% descendant (but see below) from which the
|
|
;; new class will be derived.
|
|
;; stretch-x/stretch-y: booleans which specify the default
|
|
;; stretchability behavior for the new class.
|
|
;; returns: a class, descended from wx:item%, which is suitable for
|
|
;; placing in a container.
|
|
;; Note: the item% parameter does not necessarily HAVE to be a
|
|
;; descendant of wx:item%, so long as it contains the identifiers in the
|
|
;; inherit section below. You will note below that I ran wx:panel%
|
|
;; through this function to create panel%.
|
|
|
|
(define make-item%
|
|
(lambda (item% x-margin-w y-margin-h stretch-x stretch-y)
|
|
(class100 (wx-make-window% item% #f) (window-style . args)
|
|
(inherit get-width get-height get-x get-y
|
|
get-parent get-client-size get-top-level)
|
|
(private-field [enabled? #t])
|
|
(override
|
|
[enable
|
|
(lambda (b)
|
|
(set! enabled? (and b #t))
|
|
(super enable b))]
|
|
|
|
;; set-size: caches calls to set-size to avoid unnecessary work,
|
|
;; and works with windowsless panels
|
|
;; input: x/y: new position for object
|
|
;; width/height: new size for object
|
|
;; returns: nothing
|
|
;; effect: if arguments mark a different geometry than the object's
|
|
;; current geometry, passes args to super-class's set-size.
|
|
;; Otherwise, does nothing.
|
|
[set-size
|
|
(lambda (x y width height)
|
|
(set! x (+ x (send (area-parent) dx)))
|
|
(set! y (+ y (send (area-parent) dy)))
|
|
(unless (and (same-dimension? x (get-x))
|
|
(same-dimension? y (get-y))
|
|
(same-dimension? width (get-width))
|
|
(same-dimension? height (get-height)))
|
|
(super set-size x y width height)))])
|
|
|
|
(public
|
|
[is-enabled?
|
|
(lambda () enabled?)])
|
|
|
|
(private-field
|
|
;; Store minimum size of item.
|
|
;; This will never change after the item is created.
|
|
hard-min-width
|
|
hard-min-height)
|
|
(public
|
|
[set-min-height (lambda (v) (set! hard-min-height v) (min-height v))]
|
|
[set-min-width (lambda (v) (set! hard-min-width v) (min-width v))]
|
|
[get-hard-minimum-size (lambda () (values hard-min-width hard-min-height))]
|
|
|
|
[client-inset
|
|
(lambda (h?)
|
|
(let ([h #f][w #f])
|
|
(unless h
|
|
(let ([w-box (box 0)]
|
|
[h-box (box 0)])
|
|
(get-client-size w-box h-box)
|
|
(set! h (- (get-height) (unbox h-box)))
|
|
(set! w (- (get-width) (unbox w-box)))))
|
|
(if h? h w)))]
|
|
|
|
;; gets/sets user's requirement for minimum width. Errors out
|
|
;; if new value is not a non-negative real number. Forces a
|
|
;; redraw upon a set.
|
|
[min-client-width
|
|
(case-lambda
|
|
[() (- (min-width) (client-inset #f))]
|
|
[(new-width)
|
|
(check-range-integer '(method canvas<%> min-client-width) new-width)
|
|
(min-width (+ new-width (client-inset #f)))])]
|
|
[min-client-height
|
|
(case-lambda
|
|
[() (- (min-height) (client-inset #t))]
|
|
[(new-height)
|
|
(check-range-integer '(method canvas<%> min-client-height) new-height)
|
|
(min-height (+ new-height (client-inset #t)))])])
|
|
|
|
(private-field [-mw 0]
|
|
[-mh 0]
|
|
[-xm x-margin-w]
|
|
[-ym y-margin-h]
|
|
[-sx stretch-x]
|
|
[-sy stretch-y]
|
|
[first-arg (car args)])
|
|
|
|
(public
|
|
[min-width
|
|
(mk-param
|
|
-mw identity
|
|
(lambda (v)
|
|
(check-range-integer '(method area<%> min-width) v))
|
|
force-redraw)]
|
|
[min-height
|
|
(mk-param
|
|
-mh identity
|
|
(lambda (v)
|
|
(check-range-integer '(method area<%> min-height) v))
|
|
force-redraw)]
|
|
|
|
[x-margin
|
|
(mk-param
|
|
-xm identity
|
|
(lambda (v)
|
|
(check-margin-integer '(method subarea<%> horiz-margin) v)
|
|
v)
|
|
force-redraw)]
|
|
[y-margin
|
|
(mk-param
|
|
-ym identity
|
|
(lambda (v)
|
|
(check-margin-integer '(method subarea<%> vert-margin) v)
|
|
v)
|
|
force-redraw)]
|
|
|
|
[stretchable-in-x
|
|
(mk-param -sx (lambda (x) (and x #t)) void force-redraw)]
|
|
[stretchable-in-y
|
|
(mk-param -sy (lambda (x) (and x #t)) void force-redraw)]
|
|
|
|
;; get-info: passes necessary info up to parent.
|
|
;; input: none
|
|
;; returns: child-info struct containing the info about this
|
|
;; item.
|
|
;; intended to be called by item's parent upon resize.
|
|
[get-info
|
|
(lambda ()
|
|
(let* ([min-size (get-min-size)]
|
|
[result (make-child-info (car min-size) (cadr min-size)
|
|
(x-margin) (y-margin)
|
|
(stretchable-in-x)
|
|
(stretchable-in-y))])
|
|
result))]
|
|
|
|
[area-parent (lambda () first-arg)]
|
|
|
|
;; force-redraw: unconditionally trigger redraw.
|
|
;; input: none
|
|
;; returns: nothing
|
|
;; effects: forces the item's parent (if it exists) to redraw
|
|
;; itself. This will recompute the min-size cache if it is
|
|
;; invalid.
|
|
[force-redraw
|
|
(lambda ()
|
|
(let ([parent (area-parent)])
|
|
(when parent
|
|
(send parent child-redraw-request this))))]
|
|
|
|
[on-container-resize (lambda () (void))] ; This object doesn't contain anything
|
|
|
|
[init-min (lambda (x) x)]
|
|
|
|
;; get-min-size: computes the minimum size the item can
|
|
;; reasonably assume.
|
|
;; input: none
|
|
;; returns: a list containing the minimum width & height.
|
|
[get-min-size
|
|
(lambda ()
|
|
(let ([w (+ (* 2 (x-margin)) (max hard-min-width (min-width)))]
|
|
[h (+ (* 2 (y-margin)) (max hard-min-height (min-height)))])
|
|
(list w h)))])
|
|
|
|
(sequence
|
|
(apply super-init (send (car args) get-window) (cdr args))
|
|
(set-min-width (init-min (get-width)))
|
|
(set-min-height (init-min (get-height)))
|
|
|
|
(unless (memq 'deleted window-style)
|
|
(send (get-top-level) show-control this #t)
|
|
;; For a pane[l], the creator must call the equivalent of the following,
|
|
;; delaying to let the panel's wx field get initialized before
|
|
;; panel-sizing methods are called
|
|
(unless (is-a? this wx-basic-panel<%>)
|
|
(send (area-parent) add-child this)))))))
|
|
|
|
;; make-control% - for non-panel items
|
|
(define (make-control% item% x-margin y-margin
|
|
stretch-x stretch-y)
|
|
(class100 (make-item% item% x-margin y-margin stretch-x stretch-y) args
|
|
(inherit get-parent)
|
|
(sequence
|
|
(apply super-init args)
|
|
(send (get-parent) set-item-cursor 0 0))))
|
|
|
|
(define (make-simple-control% item%)
|
|
(make-control% item%
|
|
const-default-x-margin const-default-y-margin
|
|
#f #f))
|
|
|
|
(define wx-button% (make-window-glue%
|
|
(class100 (make-simple-control% wx:button%) (parent cb label x y w h style font)
|
|
(inherit command set-border get-top-level)
|
|
(private-field
|
|
[border? (memq 'border style)]
|
|
[border-on? border?])
|
|
(public
|
|
[defaulting (lambda (on?)
|
|
(set! border-on? on?)
|
|
(set-border border-on?))]
|
|
[has-border? (lambda () border-on?)])
|
|
(override
|
|
[char-to (lambda ()
|
|
(as-exit
|
|
(lambda ()
|
|
(command (make-object wx:control-event% 'button)))))])
|
|
(sequence (super-init style parent cb label x y w h (cons 'deleted style) font)
|
|
(when border?
|
|
(send (get-top-level) add-border-button this))))))
|
|
(define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font)
|
|
(inherit set-value get-value command)
|
|
(override
|
|
[char-to (lambda ()
|
|
(as-exit
|
|
(lambda ()
|
|
(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?))))))))
|
|
|
|
)
|
|
|