950 lines
40 KiB
Racket
950 lines
40 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/list
|
|
(prefix-in wx: "kernel.rkt")
|
|
"lock.rkt"
|
|
"const.rkt"
|
|
"gdi.rkt"
|
|
"check.rkt"
|
|
"helper.rkt"
|
|
"wx.rkt"
|
|
"wxitem.rkt"
|
|
"wxlitem.rkt"
|
|
"mrwindow.rkt"
|
|
"mrcontainer.rkt")
|
|
|
|
(provide control<%>
|
|
(protect-out basic-control%)
|
|
message%
|
|
button%
|
|
check-box%
|
|
radio-box%
|
|
slider%
|
|
gauge%
|
|
|
|
list-control<%>
|
|
choice%
|
|
list-box%
|
|
|
|
(protect-out wrap-callback
|
|
check-list-control-args
|
|
check-list-control-selection
|
|
|
|
;; Local methods:
|
|
hidden-child?
|
|
label-checker))
|
|
|
|
(define control<%>
|
|
(interface (subwindow<%>)
|
|
command))
|
|
|
|
(define-local-member-name hidden-child? label-checker)
|
|
|
|
(define basic-control%
|
|
(class* (make-subwindow% (make-window% #f (make-subarea% area%))) (control<%>)
|
|
(init mk-wx mismatches lbl parent cb cursor
|
|
;; for keyword use
|
|
[font no-val])
|
|
(define label lbl)
|
|
(define callback cb)
|
|
(define can-bitmap? (or (lbl . is-a? . wx:bitmap%)
|
|
(pair? lbl)))
|
|
(define can-string? (or (string? lbl)
|
|
(pair? lbl)))
|
|
(override*
|
|
[get-label (lambda () label)]
|
|
[get-plain-label (lambda ()
|
|
(let ([label (if (pair? label) (cadr label) label)])
|
|
(and (string? label) (wx:label->plain-label label))))]
|
|
[set-label (entry-point
|
|
(lambda (l)
|
|
((label-checker)
|
|
'(method control<%> set-label) l)
|
|
(let ([l (if (string? l)
|
|
(string->immutable-string l)
|
|
l)])
|
|
(when (or (and can-bitmap?
|
|
(l . is-a? . wx:bitmap%))
|
|
(and can-string?
|
|
(string? l)))
|
|
(send wx set-label l)
|
|
(if (pair? label)
|
|
(if (string? l)
|
|
(set! label (list (car label) l (caddr label)))
|
|
(set! label (list l (cadr label) (caddr label))))
|
|
(set! label l))))))])
|
|
(public*
|
|
[hidden-child? (lambda () #f)] ; module-local method
|
|
[label-checker (lambda () check-label-string/false)] ; module-local method
|
|
[command (lambda (e) (void (callback this e)))]) ; no entry/exit needed
|
|
(define wx #f)
|
|
(when (string? label)
|
|
(set! label (string->immutable-string label)))
|
|
(super-make-object (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches label parent cursor)
|
|
(unless (hidden-child?)
|
|
(as-exit (lambda () (send parent after-new-child this))))))
|
|
|
|
(define (wrap-callback cb)
|
|
(if (and (procedure? cb)
|
|
(procedure-arity-includes? cb 2))
|
|
(lambda (w e) (if (or (eq? 'windows (system-type))
|
|
(and (memq (system-type) '(macos macosx))
|
|
(eq? (send e get-event-type) 'slider)))
|
|
;; Mac OS slider and Windows (all): need trampoline
|
|
(wx:queue-callback
|
|
(lambda ()
|
|
(cb (wx->proxy w) e))
|
|
wx:middle-queue-key)
|
|
(cb (wx->proxy w) e)))
|
|
cb))
|
|
|
|
(define zero-bitmap #f)
|
|
|
|
(define message%
|
|
(class* basic-control% ()
|
|
(init label parent [style null]
|
|
;; The following are needed just because message% adds an
|
|
;; init argument *after* all of its parent arguments, which
|
|
;; normally can't happen.
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val]
|
|
[auto-resize #f])
|
|
(init-rest)
|
|
(rename-super [super-min-width min-width]
|
|
[super-min-height min-height]
|
|
[super-get-label get-label])
|
|
(define do-auto-resize? auto-resize)
|
|
(define orig-font (or (no-val->#f font)
|
|
normal-control-font))
|
|
(define dx 0)
|
|
(define dy 0)
|
|
(override*
|
|
[label-checker (lambda () check-label-string-or-bitmap)] ; module-local method
|
|
[set-label (entry-point
|
|
(lambda (l)
|
|
(super set-label l)
|
|
(when do-auto-resize?
|
|
(do-auto-resize))))])
|
|
(private*
|
|
[strip-amp (lambda (s) (if (string? s)
|
|
(regexp-replace* #rx"&(.)" s "\\1")
|
|
s))]
|
|
[do-auto-resize (lambda ()
|
|
(let ([s (strip-amp (super-get-label))])
|
|
(cond
|
|
[(symbol? s) (void)]
|
|
[(string? s)
|
|
(let ([m (mred->wx this)])
|
|
(if (send m set-preferred-size)
|
|
(let ([w (box 0)] [h (box 0)])
|
|
(send m get-size w h)
|
|
(super-min-width (unbox w))
|
|
(super-min-height (unbox h)))
|
|
(let-values ([(mw mh) (get-window-text-extent s orig-font #t)])
|
|
(super-min-width (+ dx mw))
|
|
(super-min-height (+ dy mh)))))]
|
|
[(s . is-a? . wx:bitmap%)
|
|
(super-min-width (+ dx (send s get-width)))
|
|
(super-min-height (+ dy (send s get-height)))])))])
|
|
(define auto-resize-parm
|
|
(case-lambda
|
|
[() do-auto-resize?]
|
|
[(on?)
|
|
(as-entry
|
|
(lambda ()
|
|
(set! do-auto-resize? (and #t))
|
|
(when on?
|
|
(do-auto-resize))))]))
|
|
(public (auto-resize-parm auto-resize))
|
|
(let ([cwho '(constructor message)])
|
|
(check-label-string/bitmap/iconsym cwho label)
|
|
(check-container-parent cwho parent)
|
|
(check-style cwho #f '(deleted) style)
|
|
(check-font cwho font))
|
|
(as-entry
|
|
(lambda ()
|
|
(super-instantiate
|
|
((lambda ()
|
|
(let ([m (make-object wx-message% this this
|
|
(mred->wx-container parent)
|
|
(if do-auto-resize?
|
|
(cond
|
|
[(string? label) ""]
|
|
[(label . is-a? . wx:bitmap%)
|
|
(unless zero-bitmap
|
|
(set! zero-bitmap (make-object wx:bitmap% 1 1)))
|
|
zero-bitmap]
|
|
[else label])
|
|
label)
|
|
-1 -1 style (no-val->#f font))])
|
|
;; Record dx & dy:
|
|
(let ([w (box 0)] [h (box 0)])
|
|
(send m get-size w h)
|
|
(let-values ([(mw mh) (cond
|
|
[(string? label)
|
|
(let ([s (if do-auto-resize?
|
|
""
|
|
(strip-amp label))]
|
|
[font orig-font])
|
|
(if (equal? s "")
|
|
(let-values ([(w h) (get-window-text-extent " " font)])
|
|
(values 0 h))
|
|
(get-window-text-extent s font)))]
|
|
[(label . is-a? . wx:bitmap%)
|
|
(if do-auto-resize?
|
|
(values 1 1)
|
|
(values (send label get-width)
|
|
(send label get-height)))]
|
|
[else (values 0 0)])])
|
|
(set! dx (- (unbox w) mw))
|
|
(set! dy (- (unbox h) mh))))
|
|
;; If auto-resize, install label now:
|
|
(when (and do-auto-resize?
|
|
(not (symbol? label)))
|
|
(send m set-label label))
|
|
m))
|
|
(lambda ()
|
|
(let ([cwho '(constructor message)])
|
|
(check-container-ready cwho parent)))
|
|
label parent void #f)
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])
|
|
(when do-auto-resize?
|
|
(do-auto-resize))))))
|
|
|
|
(define button%
|
|
(class* basic-control% ()
|
|
(init label parent [callback (lambda (b e) (void))] [style null]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(override*
|
|
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
|
|
(let ([cwho '(constructor button)])
|
|
(check-label-string-or-bitmap-or-both cwho label)
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback)
|
|
(check-style cwho #f '(border deleted) style)
|
|
(check-font cwho font))
|
|
(as-entry
|
|
(lambda ()
|
|
(super-new
|
|
[mk-wx
|
|
(lambda () (make-object wx-button% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label -1 -1 -1 -1 style (no-val->#f font)))]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor button)])
|
|
(check-container-ready cwho parent)))]
|
|
[cursor #f]
|
|
[lbl label]
|
|
[parent parent]
|
|
[cb callback]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))))
|
|
|
|
(define check-box%
|
|
(class basic-control%
|
|
(init label parent [callback (lambda (b e) (void))] [style null] [value #f]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(let ([cwho '(constructor check-box)])
|
|
(check-label-string-or-bitmap cwho label)
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback)
|
|
(check-style cwho #f '(deleted) style)
|
|
(check-font cwho font))
|
|
(override*
|
|
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
|
|
(define wx #f)
|
|
(public*
|
|
[get-value (entry-point (lambda () (send wx get-value)))]
|
|
[set-value (entry-point (lambda (v) (send wx set-value v)))])
|
|
(as-entry
|
|
(lambda ()
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(set! wx (make-object wx-check-box% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label -1 -1 -1 -1 style (no-val->#f font)))
|
|
wx)]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor check-box)])
|
|
(check-container-ready cwho parent)))]
|
|
[lbl label]
|
|
[parent parent]
|
|
[cb callback]
|
|
[cursor #f]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))
|
|
(when value (set-value #t))))
|
|
|
|
(define radio-box%
|
|
(class basic-control%
|
|
(init label choices parent [callback (lambda (b e) (void))] [style '(vertical)] [selection 0]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(define chcs choices)
|
|
(let ([cwho '(constructor radio-box)])
|
|
(check-label-string/false cwho label)
|
|
(unless (and (list? chcs) (pair? chcs)
|
|
(or (andmap label-string? chcs)
|
|
(andmap (lambda (x) (is-a? x wx:bitmap%)) chcs)))
|
|
(raise-argument-error (who->name cwho) "(or/c (non-empty-listof label-string?) (non-empty-listof (is-a?/c bitmap%)))" chcs))
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback)
|
|
(check-orientation cwho style)
|
|
(check-non-negative-integer/false cwho selection))
|
|
(define wx #f)
|
|
(private*
|
|
[check-button
|
|
(lambda (method n false-ok?)
|
|
((if false-ok?
|
|
check-non-negative-integer/false
|
|
check-non-negative-integer)
|
|
`(method radio-box% ,method) n)
|
|
(when n
|
|
(unless (< n (length chcs))
|
|
(raise-arguments-error (who->name `(method radio-box% ,method)) "no such button"
|
|
"index" n))))])
|
|
(override*
|
|
[enable (entry-point
|
|
(case-lambda
|
|
[(on?) (send wx enable on?)]
|
|
[(which on?) (check-button 'enable which #f)
|
|
(send wx enable which on?)]))]
|
|
[is-enabled? (entry-point
|
|
(case-lambda
|
|
[() (send wx is-enabled?)]
|
|
[(which) (check-button 'is-enabled? which #f)
|
|
(send wx is-enabled? which)]))])
|
|
(public*
|
|
[get-number (lambda () (length chcs))]
|
|
[get-item-label (lambda (n)
|
|
(check-button 'get-item-label n #f)
|
|
(list-ref chcs n))]
|
|
[get-item-plain-label (lambda (n)
|
|
(check-button 'get-item-plain-label n #f)
|
|
(wx:label->plain-label (list-ref chcs n)))]
|
|
|
|
[get-selection (entry-point (lambda () (let ([v (send wx get-selection)])
|
|
(if (equal? v -1)
|
|
#f
|
|
v))))]
|
|
[set-selection (entry-point
|
|
(lambda (v)
|
|
(check-button 'set-selection v #t)
|
|
(send wx set-selection (or v -1))))])
|
|
(as-entry
|
|
(lambda ()
|
|
(when (andmap string? chcs)
|
|
(set! chcs (map string->immutable-string chcs)))
|
|
(super-instantiate
|
|
((lambda ()
|
|
(set! wx (make-object wx-radio-box% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label -1 -1 -1 -1 chcs 0 style (no-val->#f font)))
|
|
wx)
|
|
(lambda ()
|
|
(let ([cwho '(constructor radio-box)])
|
|
(check-container-ready cwho parent)
|
|
(when selection
|
|
(check-list-control-selection cwho choices selection))))
|
|
label parent callback #f)
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))
|
|
(when (or (not selection) (positive? selection))
|
|
(set-selection selection))))
|
|
|
|
(define slider%
|
|
(class basic-control%
|
|
(init label min-value max-value parent [callback (lambda (b e) (void))] [init-value min-value] [style '(horizontal)]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(define minv min-value)
|
|
(define maxv max-value)
|
|
(let ([cwho '(constructor slider)])
|
|
(check-label-string/false cwho label)
|
|
(check-slider-integer cwho minv)
|
|
(check-slider-integer cwho maxv)
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback)
|
|
(check-slider-integer cwho init-value)
|
|
(check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style)
|
|
(check-font cwho font)
|
|
(unless (<= minv maxv)
|
|
(raise-arguments-error (who->name cwho)
|
|
"minumum value is greater than maximum value"
|
|
"minimum" minv
|
|
"maximum" maxv))
|
|
(unless (<= minv init-value maxv)
|
|
(raise-arguments-error (who->name cwho)
|
|
"range error;\n initial value is not between minumum value and maximum value inclusive"
|
|
"initial value" init-value
|
|
"minimum" minv
|
|
"maximum" maxv)))
|
|
(define wx #f)
|
|
(public*
|
|
[get-value (entry-point (lambda () (send wx get-value)))]
|
|
[set-value (entry-point
|
|
(lambda (v)
|
|
(check-slider-integer '(method slider% set-value) v)
|
|
(unless (<= minv v maxv)
|
|
(raise-arguments-error (who->name '(method slider% set-value))
|
|
"out of range;\n given value is not between minimum and maximum values"
|
|
"given" v
|
|
"minimum" minv
|
|
"maximum" maxv))
|
|
(send wx set-value v)))])
|
|
(as-entry
|
|
(lambda ()
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(set! wx (make-object wx-slider% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label init-value minv maxv style (no-val->#f font)))
|
|
wx)]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor slider)])
|
|
(check-container-ready cwho parent)))]
|
|
[lbl label]
|
|
[parent parent]
|
|
[cb callback]
|
|
[cursor #f]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))))
|
|
|
|
(define gauge%
|
|
(class basic-control%
|
|
(init label range parent [style '(horizontal)]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(let ([cwho '(constructor gauge)])
|
|
(check-label-string/false cwho label)
|
|
(check-container-parent cwho parent)
|
|
(check-gauge-integer cwho range)
|
|
(check-orientation cwho style))
|
|
(define wx #f)
|
|
(public*
|
|
[get-value (entry-point (lambda () (send wx get-value)))]
|
|
[set-value (entry-point
|
|
(lambda (v)
|
|
(check-gauge-range-integer '(method gauge% set-value) v)
|
|
(when (> v (send wx get-range))
|
|
(raise-arguments-error (who->name '(method gauge% set-value))
|
|
"out of range;\n given value is not between 0 and maximum value"
|
|
"given" v
|
|
"maximum" (send wx get-range)))
|
|
(send wx set-value v)))]
|
|
[get-range (entry-point (lambda () (send wx get-range)))]
|
|
[set-range (entry-point
|
|
(lambda (v)
|
|
(check-gauge-integer '(method gauge% set-range) v)
|
|
(send wx set-range v)))])
|
|
(as-entry
|
|
(lambda ()
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(set! wx (make-object wx-gauge% this this
|
|
(mred->wx-container parent)
|
|
label range style (no-val->#f font)))
|
|
wx)]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor gauge)])
|
|
(check-container-ready cwho parent)))]
|
|
[lbl label]
|
|
[parent parent]
|
|
[cb void]
|
|
[cursor #f]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))))
|
|
|
|
;; List controls ----------------------------------------
|
|
|
|
(define list-control<%>
|
|
(interface (control<%>)
|
|
clear append
|
|
get-number
|
|
get-string find-string
|
|
get-selection
|
|
get-string-selection
|
|
set-selection
|
|
set-string-selection))
|
|
|
|
(define (-1=>false v) (if (negative? v) #f v))
|
|
|
|
(define-local-member-name
|
|
-append-list-string
|
|
-set-list-strings
|
|
-set-list-string
|
|
-delete-list-item)
|
|
|
|
(define basic-list-control%
|
|
(class* basic-control% (list-control<%>)
|
|
(init mk-wx mismatches label parent selection callback init-choices)
|
|
(define content (map string->immutable-string init-choices))
|
|
(define -append
|
|
(entry-point (lambda (i)
|
|
(check-label-string '(method list-control<%> append) i)
|
|
(-append-list-string i)
|
|
(send wx append i))))
|
|
(public [-append append])
|
|
(public*
|
|
[clear (entry-point (lambda () (send wx clear) (set! content null)))]
|
|
[get-number (entry-point (lambda () (send wx number)))]
|
|
[get-string (entry-point (lambda (n) (check-item 'get-string n) (list-ref content n)))]
|
|
[get-selection (entry-point (lambda () (and (positive? (send wx number)) (-1=>false (send wx get-selection)))))]
|
|
[get-string-selection (entry-point (lambda () (and (positive? (send wx number))
|
|
(let ([v (send wx get-selection)])
|
|
(if (= v -1)
|
|
#f
|
|
(list-ref content v))))))]
|
|
[set-selection (entry-point (lambda (s) (check-item 'set-selection s) (send wx set-selection s)))]
|
|
[set-string-selection (entry-point
|
|
(lambda (s)
|
|
(check-label-string '(method list-control<%> set-string-selection) s)
|
|
(let ([pos (do-find-string s)])
|
|
(if pos
|
|
(send wx set-selection pos)
|
|
(raise-arguments-error (who->name '(method list-control<%> set-string-selection))
|
|
"no item matching the given string"
|
|
"given" s)))))]
|
|
[find-string (entry-point (lambda (x)
|
|
(check-label-string '(method list-control<%> find-string) x)
|
|
(do-find-string x)))]
|
|
[delete (entry-point (lambda (n)
|
|
(check-item 'delete n)
|
|
(send this -delete-list-item n)
|
|
(send wx delete n)))]
|
|
[-append-list-string (lambda (i)
|
|
(set! content (append content (list i))))]
|
|
[-set-list-string (lambda (i s)
|
|
(set! content (let loop ([content content][i i])
|
|
(if (zero? i)
|
|
(cons (string->immutable-string s) (cdr content))
|
|
(cons (car content) (loop (cdr content) (sub1 i)))))))]
|
|
[-delete-list-item (lambda (pos)
|
|
(set! content (let loop ([content content][pos pos])
|
|
(if (zero? pos)
|
|
(cdr content)
|
|
(cons (car content) (loop (cdr content) (sub1 pos)))))))]
|
|
[-set-list-strings (lambda (l)
|
|
(set! content (map string->immutable-string l)))])
|
|
(define wx #f)
|
|
(private*
|
|
[do-find-string
|
|
(lambda (s)
|
|
(let loop ([l content][pos 0])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(string=? s (car l)) pos]
|
|
[else (loop (cdr l) (add1 pos))])))]
|
|
[check-item
|
|
(lambda (method n)
|
|
(check-non-negative-integer `(method list-control<%> ,method) n)
|
|
(let ([m (send wx number)])
|
|
(unless (< n m)
|
|
(raise-range-error (who->name `(method list-control<%> ,method))
|
|
"control" "item "
|
|
n
|
|
this
|
|
0
|
|
(sub1 m)
|
|
#f))))])
|
|
(as-entry
|
|
(lambda ()
|
|
(super-make-object (lambda () (set! wx (mk-wx)) wx) mismatches label parent callback #f)))
|
|
(when selection
|
|
(set-selection selection))))
|
|
|
|
(define (check-list-control-args cwho label choices parent callback)
|
|
(check-label-string/false cwho label)
|
|
(unless (and (list? choices) (andmap label-string? choices))
|
|
(raise-argument-error (who->name cwho) "(listof label-string?)" choices))
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback))
|
|
|
|
(define (check-list-control-selection cwho choices selection)
|
|
(unless (< selection (length choices))
|
|
(raise-arguments-error (who->name cwho)
|
|
"given initial selection is too large"
|
|
"given" selection
|
|
"choice count" (length choices))))
|
|
|
|
(define choice%
|
|
(class basic-list-control%
|
|
(init label choices parent [callback (lambda (b e) (void))] [style null] [selection 0]
|
|
;; This is a vestige of the old class100 keyword macro
|
|
[font no-val]
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val])
|
|
(init-rest)
|
|
(let ([cwho '(constructor choice)])
|
|
(check-list-control-args cwho label choices parent callback)
|
|
(check-style cwho #f '(vertical-label horizontal-label deleted) style)
|
|
(check-non-negative-integer cwho selection)
|
|
(check-font cwho font))
|
|
(super-new
|
|
[mk-wx
|
|
(lambda () (make-object wx-choice% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label -1 -1 -1 -1 choices style (no-val->#f font)))]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor choice)])
|
|
(check-container-ready cwho parent)
|
|
(unless (= 0 selection)
|
|
(check-list-control-selection cwho choices selection))))]
|
|
[label label]
|
|
[parent parent]
|
|
[selection (and (positive? selection) selection)]
|
|
[callback callback]
|
|
[init-choices choices]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))
|
|
|
|
(define list-box%
|
|
(class basic-list-control%
|
|
(init label choices parent [callback (lambda (b e) (void))] [style '(single)]
|
|
[selection #f] [font no-val] [label-font no-val]
|
|
;; inherited inits
|
|
[enabled #t]
|
|
[vert-margin no-val]
|
|
[horiz-margin no-val]
|
|
[min-width no-val]
|
|
[min-height no-val]
|
|
[stretchable-width no-val]
|
|
[stretchable-height no-val]
|
|
;; post inits
|
|
[columns (list "Column")] [column-order #f])
|
|
(init-rest)
|
|
(let ([cwho '(constructor list-box)])
|
|
(check-list-control-args cwho label choices parent callback)
|
|
(check-style cwho '(single multiple extended)
|
|
'(vertical-label horizontal-label deleted variable-columns
|
|
column-headers clickable-headers reorderable-headers)
|
|
style)
|
|
(check-non-negative-integer/false cwho selection)
|
|
(check-font cwho font)
|
|
(check-font cwho label-font)
|
|
(unless (and (list? columns)
|
|
(not (null? columns))
|
|
(andmap label-string? columns))
|
|
(raise-argument-error (who->name cwho) "(non-empty-listof label-string?)" columns))
|
|
(when column-order
|
|
(check-column-order cwho column-order (length columns))))
|
|
(private*
|
|
[check-column-order
|
|
(lambda (cwho column-order count)
|
|
(unless (and (list? column-order)
|
|
(andmap exact-nonnegative-integer? column-order))
|
|
(raise-argument-error (who->name cwho)
|
|
"(listof exact-nonnegative-integer?)"
|
|
column-order))
|
|
(unless (equal? (sort column-order <)
|
|
(for/list ([i (in-range (length column-order))]) i))
|
|
(raise-arguments-error (who->name cwho)
|
|
"bad column-order list;\n not a permutation of integers from 0 to one less than the list length"
|
|
"list" column-order))
|
|
(unless (= (length column-order) count)
|
|
(raise-arguments-error (who->name cwho)
|
|
"column count does not match length of column-order list"
|
|
"count" count
|
|
"list" column-order)))]
|
|
[check-column-number
|
|
(lambda (who i)
|
|
(unless (exact-nonnegative-integer? i)
|
|
(raise-argument-error (who->name who) "exact-nonnegative-integer?" i))
|
|
(unless (i . < . num-columns)
|
|
(raise-arguments-error (who->name who)
|
|
"given column index is too large"
|
|
"given" i
|
|
"column count" num-columns)))])
|
|
(define column-labels (map string->immutable-string columns))
|
|
(define num-columns (length columns))
|
|
(define variable-columns? (memq 'variable-columns style))
|
|
(rename-super [super-append append])
|
|
(define -append
|
|
(entry-point
|
|
(case-lambda
|
|
[(i)
|
|
(super-append i)]
|
|
[(i d)
|
|
(check-label-string '(method list-control<%> append) i)
|
|
(send this -append-list-string i)
|
|
(send wx append i d)])))
|
|
(override [-append append])
|
|
(public*
|
|
[get-column-labels (lambda () column-labels)]
|
|
[get-column-order (lambda () (send wx get-column-order))]
|
|
[set-column-order (lambda (co)
|
|
(check-column-order '(method list-box% set-column-order) co num-columns)
|
|
(send wx set-column-order co))]
|
|
[set-column-label (lambda (i str)
|
|
(let ([who '(method list-box% set-column-label)])
|
|
(check-column-number who i)
|
|
(check-label-string who str))
|
|
(let ([str (string->immutable-string str)])
|
|
(set! column-labels (let loop ([i i] [l column-labels])
|
|
(cond
|
|
[(zero? i) (cons str (cdr l))]
|
|
[else (cons (car l) (loop (sub1 i) (cdr l)))])))
|
|
(send wx set-column-label i str)))]
|
|
[set-column-width (lambda (i w min-size max-size)
|
|
(let ([who '(method list-box% set-column-width)])
|
|
(check-column-number who i)
|
|
(check-dimension who w)
|
|
(check-dimension who min-size)
|
|
(check-dimension who max-size)
|
|
(unless (<= min-size w)
|
|
(raise-arguments-error (who->name who)
|
|
"given size is less than mininum size"
|
|
"given" w
|
|
"minimum" min-size))
|
|
(unless (>= max-size w)
|
|
(raise-arguments-error (who->name who)
|
|
"given size is greater than maximum size"
|
|
"given" w
|
|
"maximum" max-size)))
|
|
(send wx set-column-size i w min-size max-size))]
|
|
[get-column-width (lambda (i)
|
|
(check-column-number '(method list-box% get-column-width) i)
|
|
(send wx get-column-size i))]
|
|
[delete-column (lambda (i)
|
|
(let ([who '(method list-box% delete-column)])
|
|
(check-column-number who i)
|
|
(unless variable-columns?
|
|
(raise-arguments-error
|
|
(who->name who)
|
|
"cannot delete column;\n list box was created without 'variable-columns style"
|
|
"column" i
|
|
"list box" this))
|
|
(unless (num-columns . > . 1)
|
|
(raise-arguments-error (who->name who)
|
|
"cannot delete column;\n list box has only one column"
|
|
"column" i
|
|
"list box" this)))
|
|
(as-entry
|
|
(lambda ()
|
|
(set! num-columns (sub1 num-columns))
|
|
(set! column-labels (let loop ([i i] [l column-labels])
|
|
(cond
|
|
[(zero? i) (cdr l)]
|
|
[else (cons (car l) (loop (sub1 i) (cdr l)))])))
|
|
(send wx delete-column i))))]
|
|
[append-column (lambda (label)
|
|
(let ([who '(method list-box% append-column)])
|
|
(check-label-string who label)
|
|
(unless variable-columns?
|
|
(raise-arguments-error
|
|
(who->name who)
|
|
"cannot add column;\n list box created without 'variable-columns style"
|
|
"list box" this
|
|
"new column" label)))
|
|
(as-entry
|
|
(lambda ()
|
|
(set! num-columns (add1 num-columns))
|
|
(set! column-labels (append column-labels (list label)))
|
|
(send wx append-column label))))]
|
|
|
|
[get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))]
|
|
[get-label-font (lambda () (send wx get-label-font))]
|
|
[get-selections (entry-point (lambda () (send wx get-selections)))]
|
|
[number-of-visible-items (entry-point (lambda () (send wx number-of-visible-items)))]
|
|
[is-selected? (entry-point (lambda (n) (check-item 'is-selected? n) (send wx selected? n)))]
|
|
[set (entry-point (lambda (l . more)
|
|
(let ([cwho '(method list-box% set)])
|
|
(unless (= num-columns (+ 1 (length more)))
|
|
(raise-arguments-error (who->name cwho)
|
|
"column count doesn't match argument count"
|
|
"column count" num-columns
|
|
"argument count" (add1 (length more))))
|
|
(for ([l (in-list (cons l more))])
|
|
(unless (and (list? l) (andmap label-string? l))
|
|
(raise-argument-error (who->name cwho) "(listof label-string?)" l)))
|
|
(for ([more-l (in-list more)])
|
|
(unless (= (length more-l) (length l))
|
|
(raise-arguments-error
|
|
(who->name cwho)
|
|
"first list length does not match length of later argument"
|
|
"first list length" (length l)
|
|
"larger argument length" (length more-l)))))
|
|
(send this -set-list-strings l)
|
|
(send wx set l . more)))]
|
|
[set-string (entry-point
|
|
(lambda (n d [col 0])
|
|
(let ([cwho '(method list-box% set-string)])
|
|
(check-non-negative-integer cwho n) ; int error before string
|
|
(check-label-string cwho d) ; string error before range mismatch
|
|
(unless (exact-nonnegative-integer? col)
|
|
(raise-argument-error (who->name cwho) "exact-nonnegative-integer?" col))
|
|
(unless (< -1 col num-columns)
|
|
(raise-range-error (who->name cwho)
|
|
"list box" "column "
|
|
col
|
|
this
|
|
0
|
|
(sub1 num-columns)
|
|
#f)))
|
|
(check-item 'set-string n)
|
|
(send this -set-list-string n d)
|
|
(send wx set-string n d col)))]
|
|
[set-data (entry-point (lambda (n d) (check-item 'set-data n) (send wx set-data n d)))]
|
|
[get-first-visible-item (entry-point (lambda () (send wx get-first-item)))]
|
|
[set-first-visible-item (entry-point (lambda (n)
|
|
(check-item 'set-first-visible-item n)
|
|
(send wx set-first-visible-item n)))]
|
|
[select (entry-point
|
|
(case-lambda
|
|
[(n) (check-item 'select n) (send wx select n #t)]
|
|
[(n on?) (check-item 'select n) (send wx select n on?)]))])
|
|
(define wx #f)
|
|
(private*
|
|
[check-item
|
|
(entry-point
|
|
(lambda (method n)
|
|
(check-non-negative-integer `(method list-box% ,method) n)
|
|
(let ([m (send wx number)])
|
|
(unless (< n m)
|
|
(raise-range-error (who->name `(method list-box% ,method))
|
|
"list box" "item "
|
|
n
|
|
this
|
|
0
|
|
(sub1 m)
|
|
#f)))))])
|
|
(super-new
|
|
[mk-wx
|
|
(lambda ()
|
|
(let-values ([(kind style)
|
|
(cond
|
|
[(memq 'single style) (values 'single (remq 'single style))]
|
|
[(memq 'multiple style) (values 'multiple (remq 'multiple style))]
|
|
[else (values 'extended (remq 'extended style))])])
|
|
(set! wx (make-object wx-list-box% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label kind
|
|
-1 -1 -1 -1 choices style
|
|
(no-val->#f font) (no-val->#f label-font)
|
|
column-labels
|
|
column-order)))
|
|
wx)]
|
|
[mismatches
|
|
(lambda ()
|
|
(let ([cwho '(constructor list-box)])
|
|
(check-container-ready cwho parent)
|
|
(when selection
|
|
(check-list-control-selection cwho choices selection))))]
|
|
[label label]
|
|
[parent parent]
|
|
[selection (and (pair? choices) selection)]
|
|
[callback callback]
|
|
[init-choices choices]
|
|
[font font]
|
|
[enabled enabled]
|
|
[horiz-margin horiz-margin]
|
|
[vert-margin vert-margin]
|
|
[min-width min-width]
|
|
[min-height min-height]
|
|
[stretchable-width stretchable-width]
|
|
[stretchable-height stretchable-height])))
|