suzanne.soy/racket
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
This commit is contained in:
Matthew Flatt 2008-07-24 01:35:31 +00:00
parent e7eefb84c5
commit e137994b5c
22 changed files with 234 additions and 41 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?

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

@ -33,7 +33,7 @@
(define-syntax (class100*/kw stx)
(syntax-case stx ()
[(_ base (intf ...) ((base-init ...) keywords) . rest)
[(_ base (intf ...) ((base-init ...) keywords post-init ...) . rest)
(let ([kws (syntax-local-value #'keywords)])
(with-syntax ([super-init (datum->syntax-object
stx
@ -61,5 +61,5 @@
#'(super-instantiate (arg (... ...))
[new-kw new-kw] (... ...)))]))])
(class100*
base (intf ...) (base-init ... new-init ...)
base (intf ...) (base-init ... new-init ... post-init ...)
. rest))))])))

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]

7
collects/sirmail/readr.ss
View File

@ -1050,9 +1050,8 @@
(set! icon #f))
(define sm-super-frame%
(frame:searchable-mixin
(frame:standard-menus-mixin
frame:basic%)))
(frame:standard-menus-mixin
frame:basic%))
(define sm-frame%
(class sm-super-frame%
@ -1140,8 +1139,6 @@
;; -------------------- Misc. --------------------
(inherit get-edit-target-object)
(define/override (get-text-to-search)
(send message get-editor))
[define/override on-size
(lambda (w h)

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)

1
src/mred/wxme/wx_media.h
View File

@ -408,6 +408,7 @@ class wxMediaEdit : public wxMediaBuffer
virtual wxTabSnip *OnNewTabSnip();
wxBitmap *SetAutowrapBitmap(wxBitmap *bm);
virtual void OnReflow(void);
void HideCaret(Bool hide);
Bool CaretHidden(void);

6
src/mred/wxme/wx_mpriv.cxx
View File

@ -1964,6 +1964,12 @@ void wxMediaEdit::RecalcLines(wxDC *dc, Bool calcGraphics)
if (resized && admin)
admin->Resized(FALSE);
OnReflow();
}
void wxMediaEdit::OnReflow(void)
{
}
wxBitmap *wxMediaEdit::SetAutowrapBitmap(wxBitmap *bm)

62
src/mred/wxs/wxs_mede.cxx
View File

@ -904,6 +904,7 @@ static l_TYPE l_POINT *l_MAKE_ARRAY(Scheme_Object *l, l_INTTYPE *c, char *who)
static void WordbreakCallbackToScheme(wxMediaEdit *,long*,long*,int,Scheme_Object *);
@ -975,6 +976,7 @@ class os_wxMediaEdit : public wxMediaEdit {
os_wxMediaEdit CONSTRUCTOR_ARGS((nndouble x0 = 1.0, double* x1 = NULL, int x2 = 0));
~os_wxMediaEdit();
void OnReflow();
class wxTabSnip* OnNewTabSnip();
class wxTextSnip* OnNewTextSnip();
void SetRegionData(nnlong x0, nnlong x1, class wxBufferData* x2);
@ -1076,6 +1078,40 @@ os_wxMediaEdit::~os_wxMediaEdit()
objscheme_destroy(this, (Scheme_Object *) __gc_external);
}
static Scheme_Object *os_wxMediaEditOnReflow(int n, Scheme_Object *p[]);
void os_wxMediaEdit::OnReflow()
{
Scheme_Object *p[POFFSET+0] INIT_NULLED_ARRAY({ NULLED_OUT });
Scheme_Object *v;
Scheme_Object *method INIT_NULLED_OUT;
#ifdef MZ_PRECISE_GC
os_wxMediaEdit *sElF = this;
#endif
static void *mcache = 0;
SETUP_VAR_STACK(5);
VAR_STACK_PUSH(0, method);
VAR_STACK_PUSH(1, sElF);
VAR_STACK_PUSH_ARRAY(2, p, POFFSET+0);
SET_VAR_STACK();
method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxMediaEdit_class, "on-reflow", &mcache);
if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxMediaEditOnReflow)) {
SET_VAR_STACK();
READY_TO_RETURN; ASSELF wxMediaEdit::OnReflow();
} else {
p[0] = (Scheme_Object *) ASSELF __gc_external;
v = WITH_VAR_STACK(scheme_apply(method, POFFSET+0, p));
READY_TO_RETURN;
}
}
static Scheme_Object *os_wxMediaEditOnNewTabSnip(int n, Scheme_Object *p[]);
class wxTabSnip* os_wxMediaEdit::OnNewTabSnip()
@ -3951,6 +3987,29 @@ static Scheme_Object *os_wxMediaEditSetAutowrapBitmap(int n, Scheme_Object *p[]
return WITH_REMEMBERED_STACK(objscheme_bundle_wxBitmap(r));
}
static Scheme_Object *os_wxMediaEditOnReflow(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(os_wxMediaEdit_class, "on-reflow in text%", n, p);
SETUP_VAR_STACK_REMEMBERED(1);
VAR_STACK_PUSH(0, p);
if (((Scheme_Class_Object *)p[0])->primflag)
WITH_VAR_STACK(((os_wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->wxMediaEdit::OnReflow());
else
WITH_VAR_STACK(((wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->OnReflow());
READY_TO_RETURN;
return scheme_void;
}
static Scheme_Object *os_wxMediaEditOnNewTabSnip(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -8717,13 +8776,14 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env)
wxREGGLOB(os_wxMediaEdit_class);
os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 152));
os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 153));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "call-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditCallClickback, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "remove-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditRemoveClickback, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "set-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditSetClickback, 3, 5));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "set-wordbreak-func" " method", (Scheme_Method_Prim *)os_wxMediaEditSetWordbreakFunc, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "set-autowrap-bitmap" " method", (Scheme_Method_Prim *)os_wxMediaEditSetAutowrapBitmap, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-reflow" " method", (Scheme_Method_Prim *)os_wxMediaEditOnReflow, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-tab-snip" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewTabSnip, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-string-snip" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewTextSnip, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "caret-hidden?" " method", (Scheme_Method_Prim *)os_wxMediaEditCaretHidden, 0, 0));

2
src/mred/wxs/wxs_mede.xc
View File

@ -245,6 +245,8 @@
@ v "on-new-string-snip" : wxTextSnip! OnNewTextSnip();
@ v "on-new-tab-snip" : wxTabSnip! OnNewTabSnip();
@ v "on-reflow" : void OnReflow();
@ "set-autowrap-bitmap" : wxBitmap^ SetAutowrapBitmap(wxBitmap^);
static void WordbreakCallbackToScheme(wxMediaEdit *,long*,long*,int,Scheme_Object *);