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

add on-reflow to text% and auto-size to message%

Browse Source 
svn: r10890

original commit: e137994b5cb16cb172526750cba4d32fe072eb14
This commit is contained in:
Matthew Flatt 2008-07-24 01:35:31 +00:00
parent 0c6c0b7008
commit 39ff7c3f99
16 changed files with 160 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/editor.ss
View File

@ -409,7 +409,8 @@
((void) on-set-size-constraint)
((void) after-set-size-constraint)
((void) after-split-snip s)
((void) after-merge-snips s))
((void) after-merge-snips s)
((void) on-reflow))
(super-make-object line-spacing tab-stops)
(when aw?

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

@ -181,7 +181,8 @@
(define get-window-text-extent
(let ([bm #f][dc #f])
(case-lambda
[(string font)
[(string font) (get-window-text-extent string font #f)]
[(string font combine?)
(check-string 'get-window-text-extent string)
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
(unless bm
@ -190,7 +191,7 @@
(send dc set-bitmap bm))
(unless (send bm ok?)
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
(let-values ([(w h d a) (send dc get-text-extent string font)])
(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
(values (inexact->exact w) (inexact->exact h)))])))

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

@ -809,6 +809,7 @@
set-clickback
set-wordbreak-func
set-autowrap-bitmap
on-reflow
on-new-tab-snip
on-new-string-snip
caret-hidden?

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

@ -6,6 +6,7 @@
"lock.ss"
"const.ss"
"kw.ss"
"gdi.ss"
"check.ss"
"helper.ss"
"wx.ss"
@ -97,10 +98,53 @@
(cb (wx->proxy w) e)))
cb))
(define zero-bitmap #f)
(define message%
(class100*/kw basic-control% () [(label parent [style null]) control%-keywords]
(class100*/kw basic-control% () [(label parent [style null]) control%-keywords [auto-resize #f]]
(sequence ; abuse of `sequence'!
(inherit/super [super-min-width min-width]
[super-min-height min-height]
[super-get-label get-label]
[super-get-font get-font]))
(private-field
[do-auto-resize? auto-resize]
[orig-font (or (no-val->#f font)
normal-control-font)]
[dx 0]
[dy 0])
(override
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
[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-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)))])))])
(public
[(auto-resize-parm auto-resize)
(case-lambda
[() do-auto-resize?]
[(on?)
(as-entry
(lambda ()
(set! do-auto-resize? (and #t))
(when on?
(do-auto-resize))))])])
(sequence
(let ([cwho '(constructor message)])
(check-label-string/bitmap/iconsym cwho label)
@ -109,13 +153,51 @@
(check-font cwho font))
(as-entry
(lambda ()
(super-init (lambda () (make-object wx-message% this this
(mred->wx-container parent)
label -1 -1 style (no-val->#f font)))
(super-init (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))))))
label parent void #f)
(when do-auto-resize?
(do-auto-resize)))))))
(define button%
(class100*/kw basic-control% () [(label parent [callback (lambda (b e) (void))] [style null]) control%-keywords]

2
collects/scribblings/gui/button-class.scrbl
View File

@ -12,7 +12,7 @@ Whenever a button is clicked by the user, the button's callback
(is-a?/c panel%) (is-a?/c pane%))]
[callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))]
[style (one-of/c 'border 'deleted) null]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

2
collects/scribblings/gui/check-box-class.scrbl
View File

@ -19,7 +19,7 @@ Whenever a check box is clicked by the user, the check box's value is
[callback ((is-a?/c check-box%) (is-a?/c control-event%) . -> . any) (lambda (c e) (void))]
[style (listof (one-of/c 'deleted)) null]
[value any/c #f]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

2
collects/scribblings/gui/choice-class.scrbl
View File

@ -26,7 +26,7 @@ See also
'deleted))
null]
[selection nonnegative-exact-integer? 0]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

2
collects/scribblings/gui/combo-field-class.scrbl
View File

@ -22,7 +22,7 @@ A @scheme[combo-field%] object is a @scheme[text-field%]
[style (listof (one-of/c 'horizontal-label 'vertical-label
'deleted))
null]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

2
collects/scribblings/gui/gauge-class.scrbl
View File

@ -18,7 +18,7 @@ of the gauge.
'vertical-label 'horizontal-label
'deleted))
'(horizontal)]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

2
collects/scribblings/gui/group-box-panel-class.scrbl
View File

@ -15,7 +15,7 @@ Unlike most panel classes, a group-box panel's horizontal and vertical
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))]
[style (listof (one-of/c 'deleted)) null]
[font (is-a?/c font%) @scheme[small-control-font]]
[font (is-a?/c font%) small-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

4
collects/scribblings/gui/list-box-class.scrbl
View File

@ -33,8 +33,8 @@ See also @scheme[choice%].
'deleted))
'(single)]
[selection (or/c nonnegative-exact-integer? false/c) #f]
[font (is-a?/c font%) @scheme[view-control-font]]
[label-font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) view-control-font]
[label-font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

19
collects/scribblings/gui/message-class.scrbl
View File

@ -13,14 +13,15 @@ A message control is a static line of text or a static bitmap. The
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))]
[style (listof (one-of/c 'deleted)) null]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]
[min-width (integer-in 0 10000) _graphical-minimum-width]
[min-height (integer-in 0 10000) _graphical-minimum-height]
[stretchable-width any/c #f]
[stretchable-height any/c #f])]{
[stretchable-height any/c #f]
[auto-resize any/c #f])]{
Creates a string or bitmap message initially showing @scheme[label].
@bitmaplabeluse[label] An @indexed-scheme['app],
@ -36,6 +37,20 @@ Creates a string or bitmap message initially showing @scheme[label].
@FontKWs[] @WindowKWs[] @SubareaKWs[] @AreaKWs[]
If @scheme[auto-resize] is not @scheme[#f], then automatic resizing is
initially enanbled (see @method[message% auto-resize]), and the
@scheme[message%] object's @tech{graphical minimum size} is as small as
possible.
}
@defmethod*[([(auto-resize) boolean?]
[(auto-resize [on? any/c]) void?])]{
Reports or sets whether the @scheme[message%]'s @method[area<%> min-width] and
@method[area<%> min-height] are automatically set when the label is changed
via @method[message% set-label].
}
@defmethod[#:mode override

8
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -186,14 +186,16 @@ following expression gets a command line for starting a browser:
See also @scheme[write-resource].}
@defproc[(get-window-text-extent [string string]
[font (is-a?/c font%)])
[font (is-a?/c font%)]
[combine? any/c #f])
(values nonnegative-exact-integer?
nonnegative-exact-integer?)]{
Returns the pixel size of a string drawn as a window's label or value
when drawn with the given font.
when drawn with the given font. The optional @scheme[combine?]
argument is as for @xmethod[dc<%> get-text-extent].
See also @method[dc<%> get-text-extent].
See also @xmethod[dc<%> get-text-extent].
}
@defproc[(graphical-read-eval-print-loop [eval-eventspace eventspace #f]

12
collects/scribblings/gui/text-class.scrbl
View File

@ -1456,6 +1456,18 @@ Returns a @scheme[tab-snip%] instance.
}}
@defmethod[#:mode pubment
(on-reflow)
void?]{
@methspec{
Called after @tech{locations} have changed and are recomputed for the editor.
}
@methimpl{
Does nothing.
}}
@defmethod[#:mode pubment
(on-set-size-constraint)
void?]{

2
collects/scribblings/gui/text-field-class.scrbl
View File

@ -47,7 +47,7 @@ The keymap for the text field's editor is initialized by calling the
'vertical-label 'horizontal-label
'deleted))
'(single)]
[font (is-a?/c font%) @scheme[normal-control-font]]
[font (is-a?/c font%) normal-control-font]
[enabled any/c #t]
[vert-margin (integer-in 0 1000) 2]
[horiz-margin (integer-in 0 1000) 2]

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

@ -338,6 +338,10 @@
(sequence
(apply super-init name args))))
(define (auto-mixin c% v)
(class c%
(super-new [auto-resize v])))
(define return-bmp
(make-object bitmap2% (icons-path "return.xbm") 'xbm))
(define bb-bmp
@ -352,7 +356,7 @@
(cons 'vertical-label 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? msg-auto? font)
(define-values (l il)
(let ([p (make-object horizontal-panel% ip)])
@ -360,8 +364,8 @@
(send p stretchable-height stretchy?)
(let ()
(define l (make-object (trace-mixin message%) "L\u03B9&st" #;"Messag&\u03A3" p null ($ font))) ; \u03A3 is eta
(define il (make-object (trace-mixin message%) return-bmp p null ($ font)))
(define l (make-object (trace-mixin (auto-mixin message% msg-auto?)) "L\u03B9&st" p null ($ font)))
(define il (make-object (trace-mixin (auto-mixin message% msg-auto?)) return-bmp p null ($ font)))
(add-testers "Message" l)
(add-change-label "Message" l lp #f OTHER-LABEL)
@ -544,7 +548,7 @@
(define float-frame? #f)
(define no-caption? #f)
(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init?)
(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?)
(define f (make-frame (if use-dialogs?
active-dialog%
active-frame%)
@ -586,7 +590,7 @@
(send tp set-label "Sub-sub panel")
(add-testers "Sub-sub-panel" tp)
(let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? font)])
(let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy? alternate-init? msg-auto? font)])
(add-focus-note f ep)
(send f set-info ep)
@ -598,7 +602,7 @@
(set! prev-frame f)
f)
(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init?)
(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?)
(define f2 (make-frame (if use-dialogs?
active-dialog%
active-frame%)
@ -2218,7 +2222,7 @@
(lambda (b e) (choose-next l)))))
(define make-selector-and-runner
(lambda (p1 p2 radios? size maker)
(lambda (p1 p2 radios? msg? size maker)
(define (make-radio-box lbl choices panel cb)
(let ([g (instantiate group-box-panel% (lbl panel))])
(if (= (length choices) 2)
@ -2265,10 +2269,19 @@
special-font)
(send font-radio get-selection))
(positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection))))))
(positive? (send selection-radio get-selection))
(and message-auto
(send message-auto get-value))))))
(define message-auto
(and msg?
(new check-box%
[parent p2]
[label "Auto-Size Message"])))
#t))
(make-selector-and-runner bp1 bp2 #t "Big" big-frame)
(make-selector-and-runner mp1 mp2 #f "Medium" med-frame)
(make-selector-and-runner bp1 bp2 #t #t "Big" big-frame)
(make-selector-and-runner mp1 mp2 #f #f "Medium" med-frame)
(send selector show #t)