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

.

Browse Source 
original commit: f799293d181d8f5948f3d141b85e9801c0f09482
This commit is contained in:
Matthew Flatt 2005-02-10 17:12:46 +00:00
parent a56bb83974
commit cda43e3c00
2 changed files with 26 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -49,6 +49,7 @@
20 'decorative 20 'decorative
'normal 'bold 'normal 'bold
#f)) #f))
(define ($ font) (or font normal-control-font))
(define (make-h&s cp f) (define (make-h&s cp f)
(make-object button% "Hide and Show" cp (make-object button% "Hide and Show" cp
@ -346,27 +347,21 @@
(define nruter-bmp (define nruter-bmp
(make-object bitmap% (local-path "nruter.xbm") 'xbm)) (make-object bitmap% (local-path "nruter.xbm") 'xbm))
(define position-via-style? #f)
(define (add-label-direction label-h? l) (define (add-label-direction label-h? l)
(if (and position-via-style? (not label-h?)) (if (not label-h?)
(cons 'vertical-label l) (cons 'vertical-label l)
l)) l))
(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? font) (define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits? font)
(define :::dummy:::
(when (and (not label-h?)
(not position-via-style?))
(send ip set-label-position 'vertical)))
(define-values (l il) (define-values (l il)
(let ([p (make-object horizontal-panel% ip)]) (let ([p (make-object horizontal-panel% ip)])
(send p stretchable-width stretchy?) (send p stretchable-width stretchy?)
(send p stretchable-height stretchy?) (send p stretchable-height stretchy?)
(let () (let ()
(define l (make-object (trace-mixin message%) "Messag&\uE9" p null font)) ; \uE9 is e with ' (define l (make-object (trace-mixin message%) "Messag&\uE9" p null ($ font))) ; \uE9 is e with '
(define il (make-object (trace-mixin message%) return-bmp p null font)) (define il (make-object (trace-mixin message%) return-bmp p null ($ font)))
(add-testers "Message" l) (add-testers "Message" l)
(add-change-label "Message" l lp #f OTHER-LABEL) (add-change-label "Message" l lp #f OTHER-LABEL)
@ -382,9 +377,9 @@
(send b enable #f) (send b enable #f)
(sleep/yield 5) (sleep/yield 5)
(send b enable #t)) (send b enable #t))
null font)) null ($ font)))
(define ib (make-object (trace-mixin button%) bb-bmp ip void null font)) (define ib (make-object (trace-mixin button%) bb-bmp ip void null ($ font)))
; (define ib2 (make-object button% return-bmp ip void)) ; (define ib2 (make-object button% return-bmp ip void))
@ -394,11 +389,11 @@
ip void ip void
(add-label-direction label-h? '(single)) (add-label-direction label-h? '(single))
(if alt-inits? 2 #f) (if alt-inits? 2 #f)
font font)) (or font view-control-font) ($ font)))
(define cb (make-object (trace-mixin check-box%) "C&h\u00E9ck" ip void null alt-inits? font)) ; \uE9 is e with ' (define cb (make-object (trace-mixin check-box%) "C&h\u00E9ck" ip void null alt-inits? ($ font))) ; \uE9 is e with '
(define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? font)) (define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? ($ font)))
(define rb (make-object (trace-mixin radio-box%) (define rb (make-object (trace-mixin radio-box%)
(if null-label? #f "R&ad\uEDo") ; \uED is i with ' (if null-label? #f "R&ad\uEDo") ; \uED is i with '
@ -410,7 +405,7 @@
'(horizontal) '(horizontal)
'(vertical))) '(vertical)))
(if alt-inits? 2 0) (if alt-inits? 2 0)
font)) ($ font)))
(define irb (make-object (trace-mixin radio-box%) (define irb (make-object (trace-mixin radio-box%)
(if null-label? #f "Image Ra&dio") (if null-label? #f "Image Ra&dio")
@ -422,7 +417,7 @@
'(horizontal) '(horizontal)
'(vertical))) '(vertical)))
(if alt-inits? 1 0) (if alt-inits? 1 0)
font)) ($ font)))
(define ch (make-object (trace-mixin choice%) (define ch (make-object (trace-mixin choice%)
(if null-label? #f "Ch&o\u00EDce") ; \uED is i with ' (if null-label? #f "Ch&o\u00EDce") ; \uED is i with '
@ -430,14 +425,14 @@
ip void ip void
(add-label-direction label-h? null) (add-label-direction label-h? null)
(if alt-inits? 3 0) (if alt-inits? 3 0)
font)) ($ font)))
(define txt (make-object (trace-mixin text-field%) (define txt (make-object (trace-mixin text-field%)
(if null-label? #f "T\uE9&xt") ; \uE9 is e with ' (if null-label? #f "T\uE9&xt") ; \uE9 is e with '
ip void ip void
"initial & starting" "initial & starting"
(add-label-direction label-h? '(single)) (add-label-direction label-h? '(single))
font)) ($ font)))
(set! my-txt txt) (set! my-txt txt)
(set! my-lb lb) (set! my-lb lb)
@ -578,8 +573,8 @@
(define tp (define tp
(if #f (if #f
(make-object group-box-panel% "Sub" fp null font) (make-object group-box-panel% "Sub" fp null (or font small-control-font))
(make-object tab-panel% '("Sub" "Panel") fp void null font))) (make-object tab-panel% '("Sub" "Panel") fp void '(no-border) ($ font))))
(when initially-disabled? (when initially-disabled?
(send tp enable #f)) (send tp enable #f))
@ -645,13 +640,9 @@
(when prev-frame (when prev-frame
(add-disable "Previous Tester Frame" prev-frame ep2)) (add-disable "Previous Tester Frame" prev-frame ep2))
(when (and (not label-h?)
(not position-via-style?))
(send ip2 set-label-position 'vertical))
(let () (let ()
(define co (define co
(make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null font)) (make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null ($ font)))
(define sh (make-object slider% (define sh (make-object slider%
(if null-label? #f "H S&lid\uE9r") 0 10 ip2 (if null-label? #f "H S&lid\uE9r") 0 10 ip2
@ -661,7 +652,7 @@
(add-label-direction (add-label-direction
label-h? label-h?
(if plain-slider? '(horizontal plain) '(horizontal))) (if plain-slider? '(horizontal plain) '(horizontal)))
font)) ($ font)))
(define sv (make-object slider% (define sv (make-object slider%
(if null-label? #f "V Sl&id\uE9r") 0 10 ip2 (if null-label? #f "V Sl&id\uE9r") 0 10 ip2
@ -671,21 +662,21 @@
(add-label-direction (add-label-direction
label-h? label-h?
(if plain-slider? '(vertical plain) '(vertical))) (if plain-slider? '(vertical plain) '(vertical)))
font)) ($ font)))
(define gh (make-object gauge% (define gh (make-object gauge%
(if null-label? #f "H G&aug\uE9") 100 ip2 (if null-label? #f "H G&aug\uE9") 100 ip2
(add-label-direction (add-label-direction
label-h? label-h?
'(horizontal)) '(horizontal))
font)) ($ font)))
(define gv (make-object gauge% (define gv (make-object gauge%
(if null-label? #f "V Ga&ug\uE9") 100 ip2 (if null-label? #f "V Ga&ug\uE9") 100 ip2
(add-label-direction (add-label-direction
label-h? label-h?
'(vertical)) '(vertical))
font)) ($ font)))
(define txt (make-object text-field% (define txt (make-object text-field%
(if null-label? #f "T&ext \u7238") ; \u7238 is Chinese "father" (if null-label? #f "T&ext \u7238") ; \u7238 is Chinese "father"
@ -694,16 +685,16 @@
(add-label-direction (add-label-direction
label-h? label-h?
'(multiple)) '(multiple))
font)) ($ font)))
(define tab (make-object tab-panel% (define tab (make-object tab-panel%
'("Appl\uE9" "B&anana") ip2 void '("Appl\uE9" "B&anana") ip2 void
null null
font)) ($ font)))
(define grp (make-object group-box-panel% (define grp (make-object group-box-panel%
"Group\uE9" ip2 "Group\uE9" ip2
null font)) null (or font small-control-font)))
(make-object button% "OK" tab void) (make-object button% "OK" tab void)
(make-object button% "Cancel" grp void) (make-object button% "Cancel" grp void)
@ -1099,7 +1090,6 @@
(define f (make-frame frame% "Panel Tests")) (define f (make-frame frame% "Panel Tests"))
(define h (make-object horizontal-panel% f)) (define h (make-object horizontal-panel% f))
(define kind (begin (define kind (begin
(send h set-label-position 'vertical)
(send h set-alignment 'center 'top) (send h set-alignment 'center 'top)
(make-object radio-box% (make-object radio-box%
"Kind" "Kind"
@ -1642,7 +1632,6 @@
(define p (make-object vertical-panel% f)) (define p (make-object vertical-panel% f))
(define t1 (make-object text-field% #f p (handler (lambda () t1)) "This should just fit!" style)) (define t1 (make-object text-field% #f p (handler (lambda () t1)) "This should just fit!" style))
(define t2 (make-object text-field% "Another" p (handler (lambda () t2)) "This too!" style)) (define t2 (make-object text-field% "Another" p (handler (lambda () t2)) "This too!" style))
(define junk (send p set-label-position 'vertical))
(define t3 (make-object text-field% "Catch Returns" p (handler (lambda () t3)) "And, yes, this!" (define t3 (make-object text-field% "Catch Returns" p (handler (lambda () t3)) "And, yes, this!"
(cons 'hscroll style))) (cons 'hscroll style)))
(send t1 stretchable-width #f) (send t1 stretchable-width #f)
@ -2088,9 +2077,6 @@
(make-object check-box% "Use Dialogs" clockp (make-object check-box% "Use Dialogs" clockp
(lambda (c e) (lambda (c e)
(set! use-dialogs? (send c get-value)))) (set! use-dialogs? (send c get-value))))
(make-object check-box% "Position via Style" clockp
(lambda (c e)
(set! position-via-style? (send c get-value))))
(make-object check-box% "Metal" clockp (make-object check-box% "Metal" clockp
(lambda (c e) (lambda (c e)
(set! use-metal? (send c get-value)))) (set! use-metal? (send c get-value))))
@ -2135,9 +2121,6 @@
(define mp1 (make-object horizontal-panel% mp)) (define mp1 (make-object horizontal-panel% mp))
(define mp2 (make-object horizontal-pane% mp)) (define mp2 (make-object horizontal-pane% mp))
(send bp1 set-label-position 'vertical)
(send mp1 set-label-position 'vertical)
(define pp (make-object horizontal-pane% ap)) (define pp (make-object horizontal-pane% ap))
(send bp stretchable-height #f) (send bp stretchable-height #f)
(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame))) (make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame)))
@ -2278,10 +2261,10 @@
(positive? (send label-h-radio get-selection)) (positive? (send label-h-radio get-selection))
(positive? (send label-null-radio get-selection)) (positive? (send label-null-radio get-selection))
(positive? (send stretchy-radio get-selection)) (positive? (send stretchy-radio get-selection))
(list-ref (list normal-control-font (list-ref (list #f
small-control-font small-control-font
tiny-control-font tiny-control-font
(make-object font% 20 'system)) special-font)
(send font-radio get-selection)) (send font-radio get-selection))
(positive? (send enabled-radio get-selection)) (positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection)))))) (positive? (send selection-radio get-selection))))))

21
collects/tests/mred/windowing.ss
View File

@ -112,26 +112,7 @@
(let-values ([(x y) (send f get-alignment)]) (let-values ([(x y) (send f get-alignment)])
(stv f set-alignment 'right 'bottom) (stv f set-alignment 'right 'bottom)
(stvals '(right bottom) f get-alignment) (stvals '(right bottom) f get-alignment)
(stv f set-alignment x y)) (stv f set-alignment x y)))
(when win?
(test #t 'get-label-font-kind (is-a? (send f get-label-font) font%))
(test #t 'get-label-font-kind (is-a? (send f get-control-font) font%))
(st (send f get-label-font) f get-control-font)
(let ([fnt (send f get-label-font)]
[other-font (make-object font% 20 'decorative 'normal 'bold)])
(st 'system fnt get-family)
(st 'normal fnt get-style)
(st 'normal fnt get-weight)
(stv f set-label-font other-font)
(st other-font f get-label-font)
(stv f set-label-font fnt)
(stv f set-control-font other-font)
(st other-font f get-control-font)
(stv f set-control-font fnt))
(st 'horizontal f get-label-position)
(stv f set-label-position 'vertical)
(st 'vertical f get-label-position)
(stv f set-label-position 'horizontal)))
(define (cursor-tests f) (define (cursor-tests f)
(printf "Cursor ~a~n" f) (printf "Cursor ~a~n" f)