suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: df9db3ecf97c5f81e94992cd838c6c10c291b9a2
This commit is contained in:
Matthew Flatt 2002-10-20 13:17:36 +00:00
parent afc44445b9
commit 83cd93a537
3 changed files with 87 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/mred/mred.ss
View File

@ -3946,7 +3946,7 @@
label parent #f))))))
(define check-box%
(class100 basic-control% (label parent callback [style null])
(class100 basic-control% (label parent callback [style null] [value #f])
(sequence
(let ([cwho '(constructor check-box)])
(check-label-string-or-bitmap cwho label)
@ -3967,10 +3967,11 @@
(mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 style))
wx)
label parent #f))))))
label parent #f)))
(when value (set-value #t)))))
(define radio-box%
(class100 basic-control% (label choices parent callback [style '(vertical)])
(class100 basic-control% (label choices parent callback [style '(vertical)] [selection 0])
(private-field [chcs choices])
(sequence
(let ([cwho '(constructor radio-box)])
@ -3982,7 +3983,13 @@
(check-container-parent cwho parent)
(check-callback cwho callback)
(check-orientation cwho style)
(check-container-ready cwho parent)))
(check-non-negative-integer cwho selection)
(check-container-ready cwho parent)
(unless (< selection (length choices))
(raise-mismatch-error (who->name cwho)
(format "initial selection is too large, given only ~a choices: "
(length choices))
selection))))
(private-field
[wx #f])
(private
@ -4026,7 +4033,9 @@
(mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 chcs 0 style))
wx)
label parent #f))))))
label parent #f)))
(when (positive? selection)
(set-selection selection)))))
(define slider%
(class100 basic-control% (label min-value max-value parent callback [init-value min-value] [style '(horizontal)])
@ -4114,7 +4123,7 @@
(define (-1=>false v) (if (negative? v) #f v))
(define basic-list-control%
(class100* basic-control% (list-control<%>) (mk-wx label parent)
(class100* basic-control% (list-control<%>) (mk-wx label parent selection)
(public
[append (entry-point (lambda (i) (send wx append i)))]
[clear (entry-point (lambda () (send wx clear)))]
@ -4145,7 +4154,9 @@
(sequence
(as-entry
(lambda ()
(super-init (lambda () (set! wx (mk-wx)) wx) label parent #f))))))
(super-init (lambda () (set! wx (mk-wx)) wx) label parent #f)))
(when selection
(set-selection selection)))))
(define (check-list-control-args cwho label choices parent callback)
(check-label-string/false cwho label)
@ -4154,25 +4165,39 @@
(check-container-parent cwho parent)
(check-callback cwho callback))
(define (check-list-control-selection cwho choices selection)
(unless (< selection (length choices))
(raise-mismatch-error (who->name cwho)
(format "initial selection is too large, given only ~a choices: "
(length choices))
selection)))
(define choice%
(class100 basic-list-control% (label choices parent callback [style null])
(class100 basic-list-control% (label choices parent callback [style null] [selection 0])
(sequence
(let ([cwho '(constructor choice)])
(check-list-control-args cwho label choices parent callback)
(check-style cwho #f null style)
(check-container-ready cwho parent))
(check-non-negative-integer cwho selection)
(check-container-ready cwho parent)
(unless (= 0 selection)
(check-list-control-selection cwho choices selection)))
(super-init (lambda () (make-object wx-choice% this this
(mred->wx-container parent) (wrap-callback callback)
label -1 -1 -1 -1 choices style))
label parent))))
label parent
(and (positive? selection) selection)))))
(define list-box%
(class100 basic-list-control% (label choices parent callback [style '(single)])
(class100 basic-list-control% (label choices parent callback [style '(single)] [selection 0])
(sequence
(let ([cwho '(constructor list-box)])
(check-list-control-args cwho label choices parent callback)
(check-style cwho '(single multiple extended) null style)
(check-container-ready cwho parent)))
(check-non-negative-integer/false cwho selection)
(check-container-ready cwho parent)
(when selection
(check-list-control-selection cwho choices selection))))
(rename [super-append append])
(override
[append (entry-point
@ -4232,7 +4257,7 @@
label kind
-1 -1 -1 -1 choices style)))
wx)
label parent))))
label parent (and (pair? choices) selection)))))
(define text-field%
(class100* basic-control% () (label parent callback [init-value ""] [style '(single)])
@ -5067,7 +5092,7 @@
(super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback))))
(define checkable-menu-item%
(class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void])
(class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] [checked #f])
(sequence
(check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback))
(private-field
@ -5077,7 +5102,8 @@
[check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))]
[is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))])
(sequence
(super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback))))
(super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback)
(when checked (check #t)))))
(define menu-item-container<%> (interface () get-items on-demand))
(define internal-menu<%> (interface ()))
@ -6563,9 +6589,20 @@
"real number in [0.0, 1.0]"
x)))
(define (-check-non-negative-integer who i false-ok?)
(when (or i (not false-ok?))
(unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who)
(if false-ok?
"non-negative exact integeror #f"
"non-negative exact integer" )
i))))
(define (check-non-negative-integer who i)
(unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who) "non-negative exact integer" i)))
(-check-non-negative-integer who i #f))
(define (check-non-negative-integer/false who i)
(-check-non-negative-integer who i #t))
(define check-dimension (check-bounded-integer 0 10000 #t))
(define check-non#f-dimension (check-bounded-integer 0 10000 #f))

16
collects/tests/mred/frame-steps.txt
View File

@ -52,10 +52,13 @@ Medium Frame should contain:
V Gauge (a vertical slider)
Text (a multi-line text field)
initial & starting
A tab panel with two tabs
The names on labels must match the above exactly (except that <>
indicates an image). Watch out for letters that are dropped or
&s that are dropped.
The names on labels must match the above exactly, except that most
labels have an "e" or "i" that gets an accent mark to test Latin-1
labels. Also, <> above indicates an image. Watch out for letters that
are dropped or &s that are dropped.
Make sure all the controls with moving parts work.
@ -273,5 +276,8 @@ Go back to the default configuration and try the 3 other combinations
of label and button fonts. The big label font should apply to external
control labels, and to message items. The button font should apply to
the content of controls (names within a button, checkbox, listbox,
choice, or text control).
choice, or text control). The "Initially" radio box controls whether
the control-containing panel is initially enabled (before the controls
it contains are created). The "Selection" radio box controls the
initial-value setting for check boxes, radio buttons, list boxes, and
choices.

34
collects/tests/mred/item.ss
View File

@ -321,7 +321,7 @@
(sequence
(apply super-init name args))))
(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?)
(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits?)
(define return-bmp
(make-object bitmap% (icons-path "return.xbm") 'xbm))
@ -367,11 +367,13 @@
(define lb (make-object (trace-mixin list-box%)
(if null-label? #f "L\355&st") ; 355 is i with '
'("Appl\351" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; 351 is e with '
ip void))
ip void
'(single)
(if alt-inits? 2 #f)))
(define cb (make-object (trace-mixin check-box%) "C&h\351ck" ip void)) ; 351 is e with '
(define cb (make-object (trace-mixin check-box%) "C&h\351ck" ip void null alt-inits?)) ; 351 is e with '
(define icb (make-object (trace-mixin check-box%) mred-bmp ip void))
(define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits?))
(define rb (make-object (trace-mixin radio-box%)
(if null-label? #f "R&ad\355o") ; 355 is i with '
@ -379,7 +381,8 @@
ip void
(if radio-h?
'(horizontal)
'(vertical))))
'(vertical))
(if alt-inits? 2 0)))
(define irb (make-object (trace-mixin radio-box%)
(if null-label? #f "Image Ra&dio")
@ -387,12 +390,15 @@
ip void
(if radio-h?
'(horizontal)
'(vertical))))
'(vertical))
(if alt-inits? 1 0)))
(define ch (make-object (trace-mixin choice%)
(if null-label? #f "Ch&o\355ce") ; 355 is i with '
'("Alpha" "Beta" "Gamma" "Delta & R\351st") ; 351 is e with '
ip void))
ip void
null
(if alt-inits? 3 0)))
(define txt (make-object (trace-mixin text-field%)
(if null-label? #f "T\351&xt") ; 351 is e with '
@ -464,7 +470,7 @@
items)))
(define (big-frame h-radio? v-label? null-label? stretchy? special-label-font? special-button-font?
initially-disabled?)
initially-disabled? alternate-init?)
(define f (make-frame active-frame% "T\351ster")) ; 351 is e with '
(define hp (make-object horizontal-panel% f))
@ -505,7 +511,7 @@
(when special-button-font?
(send tp set-control-font special-font))
(let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy?)])
(let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init?)])
(add-focus-note f ep)
(send f set-info ep)
@ -516,7 +522,7 @@
f)
(define (med-frame plain-slider? label-h? null-label? stretchy? special-label-font? special-button-font?
initially-disabled?)
initially-disabled? alternate-init?)
(define f2 (make-frame active-frame% "Tester2"))
(define hp2 (make-object horizontal-panel% f2))
@ -1953,10 +1959,13 @@
(define enabled-radio
(make-object radio-box% "Initially" '("Enabled" "Disabled")
p1 void))
(define selection-radio
(make-object radio-box% "Selection" '("Default" "Alternate")
p1 void))
(define next-button
(make-next-button p2 (list radio-h-radio label-h-radio label-null-radio
stretchy-radio label-font-radio button-font-radio
enabled-radio)))
enabled-radio selection-radio)))
(define go-button
(make-object button% (format "Make ~a Frame" size) p2
(lambda (b e)
@ -1967,7 +1976,8 @@
(positive? (send stretchy-radio get-selection))
(positive? (send label-font-radio get-selection))
(positive? (send button-font-radio get-selection))
(positive? (send enabled-radio get-selection))))))
(positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection))))))
#t))
(make-selector-and-runner bp1 bp2 #t "Big" big-frame)