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

.

Browse Source 
original commit: c167c465d0f64879d78de025b86669642c39c610
This commit is contained in:
Matthew Flatt 2005-02-10 12:20:58 +00:00
parent db46b50542
commit 4eb0097e39
9 changed files with 85 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mred/private/gdi.ss
View File

@ -16,9 +16,9 @@
get-window-text-extent
get-family-builtin-face
normal-control-font
view-control-font
small-control-font
tiny-control-font)
tiny-control-font
view-control-font)
(define register-collecting-blit
(case-lambda
@ -155,8 +155,8 @@
[else 1]))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
(define view-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% 12 'system)
(make-object wx:font% (wx:get-control-font-size) 'system)))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system)))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system))
(define view-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
normal-control-font)))

2
collects/mred/private/kernel.ss
View File

@ -664,6 +664,7 @@
(define-function is-color-display?)
(define-function file-selector)
(define-class list-box% item% #f
get-label-font
set-string
set-first-visible-item
set
@ -931,6 +932,7 @@
copy-self)
(define-class menu% object% #f
select
get-font
set-width
set-title
set-label

17
collects/mred/private/mritem.ss
View File

@ -41,12 +41,15 @@
(define-local-member-name hidden-child? label-checker)
(define-keywords control%-keywords
[font no-val]
(define-keywords control%-nofont-keywords
window%-keywords
subarea%-keywords
area%-keywords)
(define-keywords control%-keywords
[font no-val]
control%-nofont-keywords)
(define basic-control%
(class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor
;; for keyword use
@ -443,14 +446,15 @@
(define list-box%
(class100*/kw basic-list-control% ()
[(label choices parent callback [style '(single)] [selection #f])
control%-keywords]
[(label choices parent callback [style '(single)] [selection #f] [font no-val] [label-font no-val])
control%-nofont-keywords]
(sequence
(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) style)
(check-non-negative-integer/false cwho selection)
(check-font cwho font)))
(check-font cwho font)
(check-font cwho label-font)))
(rename [super-append append])
(override
[append (entry-point
@ -517,7 +521,8 @@
(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))))
-1 -1 -1 -1 choices style
(no-val->#f font) (no-val->#f label-font))))
wx)
(lambda ()
(let ([cwho '(constructor list-box)])

2
collects/mred/private/mrmenu.ss
View File

@ -300,7 +300,7 @@
(sequence
(as-entry
(lambda ()
(set! wx-menu (make-object wx-menu% this #f void))
(set! wx-menu (make-object wx-menu% this #f void #f))
(super-init parent label help-string wx-menu #f (send wx-menu get-keymap) (lambda (x) x) void)
(let ([wx-item (mred->wx this)])
(set-cdr! (send wx-item get-menu-data) wx-menu) ; for meta-shortcuts

17
collects/mred/private/mrpopup.ss
View File

@ -14,7 +14,7 @@
(provide popup-menu%)
(define popup-menu%
(class100* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void][demand-callback void])
(class100* mred% (menu-item-container<%> internal-menu<%>) ([title #f][popdown-callback void][demand-callback void][font no-val])
(private-field
[callback demand-callback])
(public
@ -31,13 +31,17 @@
(send wx get-items)))]
[set-min-width (lambda (n)
(check-range-integer '(method popup-menu% set-min-width) n)
(send wx set-width n))])
(send wx set-width n))]
[get-font (lambda ()
(send wx get-font))])
(private-field
[wx #f])
(sequence
(check-label-string/false '(constructor popup-menu) title)
(check-callback '(constructor popup-menu) popdown-callback)
(check-callback1 '(constructor popup-menu) demand-callback)
(let ([cwho '(constructor popup-menu)])
(check-label-string/false cwho title)
(check-callback cwho popdown-callback)
(check-callback1 cwho demand-callback)
(check-font cwho font))
(as-entry
(lambda ()
(set! wx (make-object wx-menu% this title
@ -57,5 +61,6 @@
(lambda () (send mwx popup-release)))))])
(if (eq? 'windows (system-type))
(wx:queue-callback go wx:middle-queue-key)
(go))))))
(go))))
(no-val->#f font)))
(super-init wx)))))))

2
collects/mred/private/mrtextfield.ss
View File

@ -120,7 +120,7 @@
(on-popup e)
#t)))))])
(private-field
[menu (new popup-menu%)])
[menu (new popup-menu% [font font])])
(sequence
(for-each (lambda (item)
(append item))

4
collects/mred/private/wxitem.ss
View File

@ -303,7 +303,7 @@
(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)
#t #t) (parent cb label kind x y w h choices style font label-font)
(inherit get-first-item
set-first-visible-item)
(private
@ -328,7 +328,7 @@
[(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 style font)))))
(sequence (super-init style parent cb label kind x y w h choices style font label-font)))))
(define wx-radio-box%
(make-window-glue%

4
collects/mred/private/wxmenu.ss
View File

@ -113,7 +113,7 @@
(super-init))))
(define wx-menu%
(class100* wx:menu% (wx<%>) (mr popup-label popup-callback)
(class100* wx:menu% (wx<%>) (mr popup-label popup-callback font)
(private-field
[mred mr]
[items null]
@ -162,4 +162,4 @@
(send iwx set-enabled (and on? #t))
(super-enable id on?)))])
(sequence
(super-init popup-label popup-callback)))))
(super-init popup-label popup-callback font)))))

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

@ -352,7 +352,7 @@
(cons 'vertical-label l)
l))
(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy? alt-inits?)
(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?)
@ -365,8 +365,8 @@
(send p stretchable-height stretchy?)
(let ()
(define l (make-object (trace-mixin message%) "Messag&\uE9" p)) ; \uE9 is e with '
(define il (make-object (trace-mixin message%) return-bmp p))
(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))
(add-testers "Message" l)
(add-change-label "Message" l lp #f OTHER-LABEL)
@ -381,9 +381,10 @@
(lambda (b e)
(send b enable #f)
(sleep/yield 5)
(send b enable #t))))
(send b enable #t))
null font))
(define ib (make-object (trace-mixin button%) bb-bmp ip void))
(define ib (make-object (trace-mixin button%) bb-bmp ip void null font))
; (define ib2 (make-object button% return-bmp ip void))
@ -392,11 +393,12 @@
'("Appl\uE9" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; \uE9 is e with '
ip void
(add-label-direction label-h? '(single))
(if alt-inits? 2 #f)))
(if alt-inits? 2 #f)
font font))
(define cb (make-object (trace-mixin check-box%) "C&h\u00E9ck" ip void null alt-inits?)) ; \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?))
(define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? font))
(define rb (make-object (trace-mixin radio-box%)
(if null-label? #f "R&ad\uEDo") ; \uED is i with '
@ -407,7 +409,8 @@
(if radio-h?
'(horizontal)
'(vertical)))
(if alt-inits? 2 0)))
(if alt-inits? 2 0)
font))
(define irb (make-object (trace-mixin radio-box%)
(if null-label? #f "Image Ra&dio")
@ -418,20 +421,23 @@
(if radio-h?
'(horizontal)
'(vertical)))
(if alt-inits? 1 0)))
(if alt-inits? 1 0)
font))
(define ch (make-object (trace-mixin choice%)
(if null-label? #f "Ch&o\u00EDce") ; \uED is i with '
'("Alpha" "Beta" "Gamma" "Delta & R\uE9st") ; \uE9 is e with '
ip void
(add-label-direction label-h? null)
(if alt-inits? 3 0)))
(if alt-inits? 3 0)
font))
(define txt (make-object (trace-mixin text-field%)
(if null-label? #f "T\uE9&xt") ; \uE9 is e with '
ip void
"initial & starting"
(add-label-direction label-h? '(single))))
(add-label-direction label-h? '(single))
font))
(set! my-txt txt)
(set! my-lb lb)
@ -543,8 +549,7 @@
(define float-frame? #f)
(define no-caption? #f)
(define (big-frame h-radio? v-label? null-label? stretchy? special-label-font? special-button-font?
initially-disabled? alternate-init?)
(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init?)
(define f (make-frame (if use-dialogs?
active-dialog%
active-frame%)
@ -573,8 +578,8 @@
(define tp
(if #f
(make-object group-box-panel% "Sub" fp)
(make-object tab-panel% '("Sub" "Panel") fp void)))
(make-object group-box-panel% "Sub" fp null font)
(make-object tab-panel% '("Sub" "Panel") fp void null font)))
(when initially-disabled?
(send tp enable #f))
@ -586,12 +591,7 @@
(send tp set-label "Sub-sub panel")
(add-testers "Sub-sub-panel" tp)
(when special-label-font?
(send tp set-label-font special-font))
(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? alternate-init?)])
(let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? font)])
(add-focus-note f ep)
(send f set-info ep)
@ -603,8 +603,7 @@
(set! prev-frame f)
f)
(define (med-frame plain-slider? label-h? null-label? stretchy? special-label-font? special-button-font?
initially-disabled? alternate-init?)
(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init?)
(define f2 (make-frame (if use-dialogs?
active-dialog%
active-frame%)
@ -650,14 +649,9 @@
(not position-via-style?))
(send ip2 set-label-position 'vertical))
(when special-label-font?
(send ip2 set-label-font special-font))
(when special-button-font?
(send ip2 set-control-font special-font))
(let ()
(define co
(make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello"))
(make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null font))
(define sh (make-object slider%
(if null-label? #f "H S&lid\uE9r") 0 10 ip2
@ -666,7 +660,8 @@
5
(add-label-direction
label-h?
(if plain-slider? '(horizontal plain) '(horizontal)))))
(if plain-slider? '(horizontal plain) '(horizontal)))
font))
(define sv (make-object slider%
(if null-label? #f "V Sl&id\uE9r") 0 10 ip2
@ -675,19 +670,22 @@
5
(add-label-direction
label-h?
(if plain-slider? '(vertical plain) '(vertical)))))
(if plain-slider? '(vertical plain) '(vertical)))
font))
(define gh (make-object gauge%
(if null-label? #f "H G&aug\uE9") 100 ip2
(add-label-direction
label-h?
'(horizontal))))
'(horizontal))
font))
(define gv (make-object gauge%
(if null-label? #f "V Ga&ug\uE9") 100 ip2
(add-label-direction
label-h?
'(vertical))))
'(vertical))
font))
(define txt (make-object text-field%
(if null-label? #f "T&ext \u7238") ; \u7238 is Chinese "father"
@ -695,14 +693,17 @@
"initial & starting"
(add-label-direction
label-h?
'(multiple))))
'(multiple))
font))
(define tab (make-object tab-panel%
'("Appl\uE9" "B&anana") ip2 void
null))
null
font))
(define grp (make-object group-box-panel%
"Group\uE9" ip2))
"Group\uE9" ip2
null font))
(make-object button% "OK" tab void)
(make-object button% "Cancel" grp void)
@ -2239,7 +2240,9 @@
(lambda (p1 p2 radios? size maker)
(define (make-radio-box lbl choices panel cb)
(let ([g (instantiate group-box-panel% (lbl panel))])
(make-object radio-box% #f choices g cb)))
(if (= (length choices) 2)
(make-object radio-box% #f choices g cb)
(make-object choice% #f choices g cb))))
(define radio-h-radio
(make-radio-box
(if radios? "Radio Box Orientation" "Slider Style")
@ -2254,11 +2257,8 @@
(define stretchy-radio
(make-radio-box "Stretchiness" '("Normal" "All Stretchy")
p1 void))
(define label-font-radio
(make-radio-box "Label Font" '("Normal" "Big")
p1 void))
(define button-font-radio
(make-radio-box "Control Font" '("Normal" "Big")
(define font-radio
(make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big")
p1 void))
(define enabled-radio
(make-radio-box "Initially" '("Enabled" "Disabled")
@ -2268,7 +2268,7 @@
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
stretchy-radio font-radio
enabled-radio selection-radio)))
(define go-button
(make-object button% (format "Make ~a Frame" size) p2
@ -2278,8 +2278,11 @@
(positive? (send label-h-radio get-selection))
(positive? (send label-null-radio get-selection))
(positive? (send stretchy-radio get-selection))
(positive? (send label-font-radio get-selection))
(positive? (send button-font-radio get-selection))
(list-ref (list normal-control-font
small-control-font
tiny-control-font
(make-object font% 20 'system))
(send font-radio get-selection))
(positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection))))))
#t))