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

Adjust DrRacket so the window can get narrower

Browse Source 
For example, a new DrRacket window (with a file named tmp.rkt in the
and 356 afterwards.  This is under mac os x with, I believe, the
default system font sizes. (The file is important because different
languages can have different buttons in the toolbar and the filename's
length itself can affect the minimum size.)

Mostly this change is the addition of a new kind of panel that
lets its children have multiple fixed sizes (as opposed to
just a single minimum size and (optionally  arbitrarily large))
It also adjusts the various toolbar buttons to use this new code.

Also, there's a few tweaks to shrink other things that became the
limiting factor in shrinking the width of the DrRacket window.

Currently, at least for #lang racket programs, the toolbar buttons
along the top of the window are the limiting factor (including the
save button).  With a bogus language (ie, #lang rackeeet), the bottom
bar is the limiting factor, since that will have only the Save, Run,
and Stop buttons.

related to PR 13281
This commit is contained in:
Robby Findler 2012-11-29 09:20:25 -06:00
parent a45f94b58b
commit 993cd40208
12 changed files with 452 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/drracket/private/module-language-tools.rkt
View File

@ -83,9 +83,10 @@
(sort-toolbar-buttons-panel))) (sort-toolbar-buttons-panel)))
(super-new) (super-new)
(inherit get-button-panel) (inherit get-button-panel)
(set! toolbar-button-panel (new horizontal-panel% (set! toolbar-button-panel (new panel:horizontal-discrete-sizes%
[parent (get-button-panel)] [parent (get-button-panel)]
[stretchable-width #f])) [alignment '(right center)]
[stretchable-width #t]))
(after-initialized) (after-initialized)
(set! after-initialized void) (set! after-initialized void)

19
collects/drracket/private/unit.rkt
View File

@ -55,8 +55,6 @@ module browser threading seems wrong.
(define show-planet-paths (string-constant module-browser-show-planet-paths/short)) (define show-planet-paths (string-constant module-browser-show-planet-paths/short))
(define refresh (string-constant module-browser-refresh)) (define refresh (string-constant module-browser-refresh))
(define define-button-long-label "(define ...)")
(define oprintf (define oprintf
(let ([op (current-output-port)]) (let ([op (current-output-port)])
(λ args (λ args
@ -1896,7 +1894,8 @@ module browser threading seems wrong.
(let loop ([obj button-panel]) (let loop ([obj button-panel])
(when (is-a? obj area-container<%>) (when (is-a? obj area-container<%>)
(when (or (is-a? obj vertical-panel%) (when (or (is-a? obj vertical-panel%)
(is-a? obj horizontal-panel%)) (is-a? obj horizontal-panel%)
(is-a? obj panel:discrete-sizes<%>))
(unless (equal? (send obj get-orientation) (not vertical?)) (unless (equal? (send obj get-orientation) (not vertical?))
(send obj set-orientation (not vertical?)))) (send obj set-orientation (not vertical?))))
(for-each loop (send obj get-children)))) (for-each loop (send obj get-children))))
@ -4372,7 +4371,10 @@ module browser threading seems wrong.
[define teachpack-items null] [define teachpack-items null]
[define break-button (void)] [define break-button (void)]
[define execute-button (void)] [define execute-button (void)]
[define button-panel (new horizontal-panel% [parent top-panel] [spacing 2])] [define button-panel (new panel:horizontal-discrete-sizes%
[parent top-panel]
[stretchable-width #t]
[alignment '(right center)])]
(define/public (get-execute-button) execute-button) (define/public (get-execute-button) execute-button)
(define/public (get-break-button) break-button) (define/public (get-break-button) break-button)
(define/public (get-button-panel) button-panel) (define/public (get-button-panel) button-panel)
@ -4454,14 +4456,9 @@ module browser threading seems wrong.
[label (string-constant break-button-label)])) [label (string-constant break-button-label)]))
(register-toolbar-button break-button #:number 101) (register-toolbar-button break-button #:number 101)
(send button-panel stretchable-height #f)
(send button-panel stretchable-width #f)
(send top-panel change-children (send top-panel change-children
(λ (l) (λ (l)
(list name-panel save-button (list name-panel save-button button-panel)))
(make-object vertical-panel% top-panel) ;; spacer
button-panel)))
(send top-panel stretchable-height #f) (send top-panel stretchable-height #f)
(inherit get-label) (inherit get-label)
@ -4816,7 +4813,7 @@ module browser threading seems wrong.
(string-constant no-full-name-since-not-saved)]) (string-constant no-full-name-since-not-saved)])
(inherit set-allow-shrinking) (inherit set-allow-shrinking)
(set-allow-shrinking 100))) (set-allow-shrinking 50)))

2
collects/framework/private/frame.rkt
View File

@ -1124,7 +1124,7 @@
[extra-menu-items (λ (menu) (add-line-number-menu-items menu))])) [extra-menu-items (λ (menu) (add-line-number-menu-items menu))]))
(define position-canvas (new position-canvas% (define position-canvas (new position-canvas%
[parent position-parent] [parent position-parent]
[init-width "000:00-000:00"])) [init-width "1:1"]))
(define/private (change-position-edit-contents str) (define/private (change-position-edit-contents str)
(send position-canvas set-str str)) (send position-canvas set-str str))

273
collects/framework/private/panel.rkt
View File

@ -1,10 +1,14 @@
#lang racket/unit #lang racket/base
(require racket/class (require racket/class
racket/list racket/list
"sig.rkt" racket/unit
mred/mred-sig) "sig.rkt"
mred/mred-sig
mrlib/switchable-button)
(provide panel@)
(define-unit panel@
(import [prefix icon: framework:icon^] (import [prefix icon: framework:icon^]
mred^) mred^)
(export framework:panel^) (export framework:panel^)
@ -634,6 +638,261 @@
;; canvas (widget -> editor) -> editor ;; canvas (widget -> editor) -> editor
(define/public (split-vertical canvas maker) (define/public (split-vertical canvas maker)
(do-split canvas maker (generic splitter-private<%> self-vertical?) (do-split canvas maker (generic splitter-private<%> self-vertical?)
vertical-panel% (generic splitter<%> split-vertical))) vertical-panel% (generic splitter<%> split-vertical)))))
))
(define discrete-child<%>
(interface ()
get-discrete-widths
get-discrete-heights))
(define discrete-sizes<%> (interface ((class->interface panel%))
get-orientation
set-orientation))
(define (discrete-get-widths c)
(cond
[(is-a? c switchable-button%)
(list (send c get-large-width)
(send c get-small-width))]
[(is-a? c discrete-sizes<%>)
(send c get-discrete-widths)]
[else
#f]))
(define (discrete-get-heights c)
(cond
[(is-a? c discrete-sizes<%>)
(send c get-discrete-heights)]
[else
#f]))
(define discrete-sizes-mixin
(mixin ((class->interface panel%)) (discrete-sizes<%> discrete-child<%>)
(inherit get-children spacing get-alignment border container-flow-modified
get-size get-client-size)
(define horizontal? #t)
(define/public (get-orientation) horizontal?)
(define/public (set-orientation h?)
(unless (equal? horizontal? h?)
(set! horizontal? h?)
(container-flow-modified)))
(define/public (get-discrete-widths)
(cond
[horizontal?
(define ws
(for/list ([c (in-list (get-children))])
(discrete-get-widths c)))
(and (andmap values ws)
(remove-duplicates
(map
(λ (x) (apply + x))
(candidate-sizes ws))))]
[else #f]))
(define/public (get-discrete-heights)
(cond
[horizontal? #f]
[else
(define hs
(for/list ([c (in-list (get-children))])
(discrete-get-heights c)))
(and (andmap values hs)
(remove-duplicates
(map
(λ (x) (apply + x))
(candidate-sizes hs))))]))
(define/override (container-size infos)
(define the-spacing (spacing))
(define the-border (spacing))
(define-values (total-min-w total-min-h)
(for/fold ([w 0] [h 0])
([info (in-list infos)]
[n (in-naturals)])
(define-values (min-w min-h h-stretch? v-stretch?)
(apply values info))
(define this-spacing (if (zero? n) 0 the-spacing))
(cond
[horizontal?
(values (+ w this-spacing min-w)
(max h min-h))]
[else
(values (max w min-w)
(+ h this-spacing min-h))])))
(define-values (sw sh) (get-size))
(define-values (cw ch) (get-client-size))
(values (+ total-min-w the-border the-border
(- sw cw))
(+ total-min-h the-border the-border
(- sh ch))))
(define/override (place-children infos w h)
(define the-spacing (spacing))
(define the-border (border))
(define-values (halign valign) (get-alignment))
(define children (get-children))
(define all-sizess
(candidate-sizes
(for/list ([c (in-list children)]
[info (in-list infos)]
#:unless (if horizontal?
(and (not (discrete-get-widths c))
(list-ref info 2))
(and (not (discrete-get-heights c))
(list-ref info 3))))
(if horizontal?
(or (discrete-get-widths c)
(list (list-ref info 0)))
(or (discrete-get-heights c)
(list (list-ref info 1)))))))
(define fitting-sizes
(for/or ([sizes (in-list all-sizess)])
(and (<= (apply + sizes)
(- (if horizontal? w h)
(* 2 the-border)))
sizes)))
(define fixed-size (apply + fitting-sizes))
(define number-stretchable
(for/sum ([info (in-list infos)]
[c children])
(if (if horizontal?
(and (not (discrete-get-widths c))
(list-ref info 2))
(and (not (discrete-get-heights c))
(list-ref info 3)))
1
0)))
(define initial-position
(+ the-border
(if (zero? number-stretchable)
(if horizontal?
(case halign
[(right) (- w fixed-size)]
[(center) (round (/ (- w fixed-size) 2))]
[(left) 0])
(case valign
[(bottom) (- h fixed-size)]
[(center) (round (/ (- h fixed-size) 2))]
[(top) 0]))
0)))
(define-values (stretchable-size stretchable-leftover)
(if (zero? number-stretchable)
(values 0 0)
(let ([total
(- (if horizontal?
w
h)
fixed-size)])
(values (quotient total number-stretchable)
(modulo total number-stretchable)))))
(define (take-one)
(cond
[(zero? stretchable-leftover)
0]
[else
(set! stretchable-leftover (- stretchable-leftover 1))
1]))
(let loop ([infos infos]
[children children]
[spot initial-position])
(cond
[(null? infos) null]
[else
(define-values (min-w min-h h-stretch? v-stretch?)
(apply values (car infos)))
(define discrete-child? (if horizontal?
(discrete-get-widths (car children))
(discrete-get-heights (car children))))
(define this-one
(cond
[(and horizontal? h-stretch? (not discrete-child?))
(list spot
(round (- (/ h 2) (/ min-h 2)))
(+ stretchable-size (take-one))
min-h)]
[(and (not horizontal?) v-stretch? (not discrete-child?))
(list (round (- (/ w 2) (/ min-w 2)))
spot
min-w
(+ stretchable-size (take-one)))]
[horizontal?
(define size (car fitting-sizes))
(set! fitting-sizes (cdr fitting-sizes))
(list spot
(round (- (/ h 2) (/ min-h 2)))
size
min-h)]
[else
(define size (car fitting-sizes))
(set! fitting-sizes (cdr fitting-sizes))
(list (round (- (/ w 2) (/ min-w 2)))
spot
min-w
size)]))
(cons this-one (loop (cdr infos)
(cdr children)
(+ spot
(if horizontal?
(list-ref this-one 2)
(list-ref this-one 3)))))])))
(super-new)))
(define horizontal-discrete-sizes%
;; extra wrapper to get the name right
(class (discrete-sizes-mixin panel%)
(super-new)))
(define vertical-discrete-sizes%
(class (discrete-sizes-mixin panel%)
(super-new)
(inherit set-orientation)
(set-orientation #f))))
;; candidate-sizes : (listof (listof number)) -> (listof (listof number))
;; in the input, the outer list corresponds to the children for a panel,
;; and each inner list are the sizes that the children can take on.
;; This function returns each possible configuration of sizes, starting
;; with the largest for each and then shrinking each child one size
;; at a time, starting from the earlier children in the list.
;; Note that this will not try all combinations of sizes; once a child
;; has been shrunk one size, larger sizes for that child will not be
;; considered, and shrinking always proceeds from the left to the right.
(define (candidate-sizes lolon)
(define all-boxes (map (λ (x) (box (sort x >=))) lolon))
(define answer '())
(define (record-current)
(set! answer (cons (map car (map unbox all-boxes)) answer)))
(for ([box (in-list all-boxes)])
(for ([i (in-range (- (length (unbox box)) 1))])
(record-current)
(set-box! box (cdr (unbox box)))))
(record-current)
(reverse answer))
(module+ test
(require rackunit)
(define (log-em lolon) (candidate-sizes lolon))
(check-equal? (log-em '((1)))
(list '(1)))
(check-equal? (log-em '((1) (2) (3)))
(list '(1 2 3)))
(check-equal? (log-em '((4 3 2 1)))
(list '(4) '(3) '(2) '(1)))
(check-equal? (log-em '((1 2 3 4)))
(list '(4) '(3) '(2) '(1)))
(check-equal? (log-em '((5 1) (6 2) (7 3)))
(list '(5 6 7)
'(1 6 7)
'(1 2 7)
'(1 2 3)))
(check-equal? (log-em '((10 9 8) (7 6 5)))
(list '(10 7)
'(9 7)
'(8 7)
'(8 6)
'(8 5))))

8
collects/framework/private/sig.rkt
View File

@ -60,7 +60,13 @@
horizontal-dragable% horizontal-dragable%
splitter<%> splitter<%>
splitter-mixin)) splitter-mixin
discrete-sizes<%>
discrete-child<%>
discrete-sizes-mixin
horizontal-discrete-sizes%
vertical-discrete-sizes%))
(define-signature panel^ extends panel-class^ (define-signature panel^ extends panel-class^
(dragable-container-size (dragable-container-size
dragable-place-children)) dragable-place-children))

6
collects/gui-debugger/debug-tool.rkt
View File

@ -1391,7 +1391,7 @@
(label (string-constant debug-tool-button-name)) (label (string-constant debug-tool-button-name))
(bitmap debug-bitmap) (bitmap debug-bitmap)
(alternate-bitmap small-debug-bitmap) (alternate-bitmap small-debug-bitmap)
(parent (new vertical-pane% (parent (new panel:horizontal-discrete-sizes%
[parent (get-button-panel)] [parent (get-button-panel)]
[alignment '(center center)])) [alignment '(center center)]))
(callback (λ (button) (debug-callback))))) (callback (λ (button) (debug-callback)))))
@ -1526,9 +1526,9 @@
(send (send debug-button get-parent) delete-child debug-button))))) (send (send debug-button get-parent) delete-child debug-button)))))
(send (get-button-panel) change-children (send (get-button-panel) change-children
(lambda (_) (lambda (children)
(cons (send debug-button get-parent) (cons (send debug-button get-parent)
(remq (send debug-button get-parent) _)))) (remq (send debug-button get-parent) children))))
; hide debug button if it's not supported for the initial language: ; hide debug button if it's not supported for the initial language:
(check-current-language-for-debugger))) (check-current-language-for-debugger)))

2
collects/handin-client/client-gui.rkt
View File

@ -783,7 +783,7 @@
(super help-menu:after-about menu)) (super help-menu:after-about menu))
(define client-panel (define client-panel
(new vertical-pane% (parent (get-button-panel)))) (new panel:vertical-discrete-sizes% (parent (get-button-panel))))
(define client-button (define client-button
(new switchable-button% (new switchable-button%

6
collects/macro-debugger/tool.rkt
View File

@ -127,10 +127,8 @@
get-current-tab) get-current-tab)
(define macro-debug-panel (define macro-debug-panel
(new horizontal-pane% (new panel:horizontal-discrete-sizes%
(parent (get-button-panel)) (parent (get-button-panel))))
(stretchable-height #f)
(stretchable-width #f)))
(define macro-debug-button (define macro-debug-button
(new switchable-button% (new switchable-button%
(label macro-stepper-button-label) (label macro-stepper-button-label)

40
collects/mrlib/scribblings/switchable-button.scrbl
View File

@ -1,5 +1,5 @@
#lang scribble/doc #lang scribble/doc
@(require "common.rkt" (for-label mrlib/switchable-button)) @(require "common.rkt" (for-label mrlib/switchable-button framework))
@title{Switchable Button} @title{Switchable Button}
@ -12,21 +12,32 @@
display of just the icon and a display with the display of just the icon and a display with the
label and the icon side-by-side. label and the icon side-by-side.
@defconstructor/auto-super[([label string?] The @racket[panel:discrete-sizes-mixin] explicitly
[callback (-> (is-a?/c switchable-button%) any/c)] uses @racket[switchable-button%]s via their
@method[switchable-button% get-small-width] and
@method[switchable-button% get-small-height] methods.
See @racket[panel:discrete-sizes-mixin] for more details.
@defconstructor/auto-super[([label (or/c string? (is-a?/c bitmap%) #f)]
[bitmap (is-a?/c bitmap%)] [bitmap (is-a?/c bitmap%)]
[callback (-> (is-a?/c switchable-button%) any/c)]
[alternate-bitmap (is-a?/c bitmap%) bitmap] [alternate-bitmap (is-a?/c bitmap%) bitmap]
[vertical-tight? boolean? #f])]{ [vertical-tight? boolean? #f]
[min-width-includes-label? boolean? #f])]{
The @racket[callback] is called when the button The @racket[callback] is called when the button
is pressed. The @racket[string] and @racket[bitmap] are is pressed. The @racket[label] and @racket[bitmap] are
used as discussed above. used as discussed above.
If @racket[alternate-bitmap] is supplied, then it is used If @racket[alternate-bitmap] is supplied, then it is used
when the button is switched to the view that just shows the bitmap. when the label is not visible (via a call to @method[switchable-button% set-label-visible]).
If it is not supplied, both modes show the same bitmap. If it is not supplied, both modes show @racket[bitmap].
If the @racket[vertical-tight?] argument is @racket[#t], then the button takes up If the @racket[vertical-tight?] argument is @racket[#t], then the button takes up
as little as possible vertical space. as little as possible vertical space.
If the @racket[min-width-includes-label?] is @racket[#t], then the minimum
width includes both the bitmap and the label. Otherwise, it includes
only the bitmap.
} }
@defmethod[(set-label-visible [visible? boolean?]) void?]{ @defmethod[(set-label-visible [visible? boolean?]) void?]{
@ -40,4 +51,19 @@
@defmethod[(get-button-label) string?]{ @defmethod[(get-button-label) string?]{
Returns the label of this button. Returns the label of this button.
} }
@defmethod[(get-large-width) exact-nonnegative-integer?]{
Returns the width of the button when it would show both
the label and the bitmap and when it is in label-visible
mode (i.e., when @racket[set-label-visible] has been called
with @racket[#t]).
}
@defmethod[(get-small-width) exact-nonnegative-integer?]{
Returns the width of the button when it would show both
just the bitmap (not the alternate bitmap),
and when it is in label-visible
mode (i.e., when @racket[set-label-visible] has been called
with @racket[#t]).
}
} }

105
collects/mrlib/switchable-button.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/gui/base (require racket/gui/base
scheme/class) racket/class)
(provide switchable-button%) (provide switchable-button%)
(define gap 4) ;; space between the text and the icon (define gap 4) ;; space between the text and the icon
@ -57,7 +57,8 @@
bitmap bitmap
callback callback
[alternate-bitmap bitmap] [alternate-bitmap bitmap]
[vertical-tight? #f]) [vertical-tight? #f]
[min-width-includes-label? #f])
(define/public (get-button-label) label) (define/public (get-button-label) label)
@ -206,13 +207,13 @@
;; Draw background. Use alpha blending if it can work, ;; Draw background. Use alpha blending if it can work,
;; otherwise fall back to a suitable color. ;; otherwise fall back to a suitable color.
(let ([color (cond (let ([color (cond
[disabled? #f] [disabled? #f]
[in? (if (eq? (send dc get-smoothing) 'aligned) [in? (if (eq? (send dc get-smoothing) 'aligned)
(if down? 0.5 0.2) (if down? 0.5 0.2)
(if down? (if down?
half-gray half-gray
one-fifth-gray))] one-fifth-gray))]
[else #f])]) [else #f])])
(when color (when color
(send dc set-pen "black" 1 'transparent) (send dc set-pen "black" 1 'transparent)
(send dc set-brush (if (number? color) "black" color) 'solid) (send dc set-brush (if (number? color) "black" color) 'solid)
@ -232,14 +233,19 @@
(send dc set-alpha .5)) (send dc set-alpha .5))
(cond (cond
[with-label? [with-label?
(let-values ([(tw th _1 _2) (send dc get-text-extent label)]) (cond
(let ([text-start (+ (/ cw 2) [(<= cw (get-small-width))
(- (/ tw 2)) (draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2))
(- (/ (send bitmap get-width) 2)) (- (/ ch 2) (/ (send bitmap get-height) 2)))]
(- rhs-pad))]) [else
(send dc draw-text label text-start (- (/ ch 2) (/ th 2))) (define-values (tw th _1 _2) (send dc get-text-extent label))
(draw-the-bitmap (+ text-start tw gap) (- (/ ch 2) (/ (send bitmap get-height) 2)))))] (define text-start (+ (/ cw 2)
(- (/ tw 2))
(- (/ (send bitmap get-width) 2))
(- rhs-pad)))
(send dc draw-text label text-start (- (/ ch 2) (/ th 2)))
(draw-the-bitmap (+ text-start tw gap) (- (/ ch 2) (/ (send bitmap get-height) 2)))])]
[else [else
(draw-the-bitmap (- (/ cw 2) (/ (send (if with-label? bitmap alternate-bitmap) get-width) 2)) (draw-the-bitmap (- (/ cw 2) (/ (send (if with-label? bitmap alternate-bitmap) get-width) 2))
(- (/ ch 2) (/ (send (if with-label? bitmap alternate-bitmap) get-height) 2)))]) (- (/ ch 2) (/ (send (if with-label? bitmap alternate-bitmap) get-height) 2)))])
@ -268,22 +274,53 @@
(refresh))) (refresh)))
(define/private (update-sizes) (define/private (update-sizes)
(let ([dc (get-dc)]) (define dc (get-dc))
(cond (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font))
[with-label? (define h
(let-values ([(w h _1 _2) (send dc get-text-extent label normal-control-font)]) (inexact->exact
(do-w/h (+ w gap (send bitmap get-width) rhs-pad) (floor
(max h (send bitmap get-height))))] (+ (max th
[else (send alternate-bitmap get-height)
(do-w/h (send alternate-bitmap get-width) (send bitmap get-height))
(send alternate-bitmap get-height))]))) h-circle-space margin margin
(if vertical-tight? -6 0)))))
(cond
[with-label?
(cond
[min-width-includes-label?
(min-width (get-large-width))]
[else
(min-width (get-small-width))])
(min-height h)]
[else
(min-width (get-without-label-small-width))
(min-height h)]))
(define/private (do-w/h w h) (define/public (get-large-width)
(let ([w (floor (inexact->exact w))] (define dc (get-dc))
[h (floor (inexact->exact h))]) (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font))
(min-width (+ w w-circle-space margin margin)) (inexact->exact
(min-height (+ h h-circle-space margin margin (floor
(if vertical-tight? -6 0))))) (+ (+ tw gap (send bitmap get-width) rhs-pad)
w-circle-space
margin
margin))))
(define/private (get-without-label-small-width)
(inexact->exact
(floor
(+ (send alternate-bitmap get-width)
w-circle-space
margin
margin))))
(define/public (get-small-width)
(inexact->exact
(floor
(+ (send bitmap get-width)
w-circle-space
margin
margin))))
(super-new [style '(transparent no-focus)]) (super-new [style '(transparent no-focus)])
(send (get-dc) set-smoothing 'aligned) (send (get-dc) set-smoothing 'aligned)

58
collects/scribblings/framework/panel.scrbl
View File

@ -1,7 +1,6 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual scribble/extract) @(require scribble/manual scribble/extract)
@(require (for-label framework)) @(require (for-label framework mrlib/switchable-button racket/gui))
@(require (for-label scheme/gui))
@title{Panel} @title{Panel}
@definterface[panel:single<%> (area-container<%>)]{ @definterface[panel:single<%> (area-container<%>)]{
@ -219,4 +218,59 @@
} }
@definterface[panel:discrete-sizes<%> ()]{
Classes implementing this interface support children
with multiple fixed sizes. As the panel is resized,
it calculates a set of sizes of its children
that fills its available size and approtions the space accordingly
using only one of the fixed sizes.
The strategy it uses is to try to give the largest of
the sizes to children that appear later in
the list of children (to the right horizontal and lower
vertically). It does not try all possible combinations.
Each child that supports minimum sizes is expected to
implement the @racket[panel:discrete-child<%>] interface.
Children that do not implement this interface are just
treated like @racket[horizontal-panel%] or @racket[vertical-panel%]
would treat them, with the exception of
@racket[switchable-button%]. In that case, the
results of
@method[switchable-button% get-small-width] and
@method[switchable-button% get-large-width] are
treated as the two fixed sizes for instances of that class.
Also note that, the orientation of the panel determines whether
or not it treats heights or widths as described above. That is,
when a panel is in vertical mode, it ignores the horizontal
discrete sizes, and vice-versa.
@defmethod[(set-orientation [horizontal? boolean?]) void?]{
Changes the orientation of the panel.
}
@defmethod[(get-orientation) boolean?]{
Returns the current orientation of the panel.
}
}
@definterface[panel:discrete-child<%> ()]{
Classes that implement this method collaborate with
@racket[panel:discrete-sizes<%>] to indicate
which fixed sizes they support.
@defmethod[(get-discrete-widths) (listof exact-nonnegative-integer?)]{
Return a list of widths this class supports.
}
@defmethod[(get-discrete-heights) (listof exact-nonnegative-integer?)]{
Return a list of heights this class supports.
}
}
@defmixin[panel:discrete-sizes-mixin (panel%) (panel:discrete-sizes<%> panel:discrete-child<%>)]{
Provides an implementation of @racket[panel:discrete-sizes<%>].
It uses the sizes of its children to implement the @racket[panel:discrete-child<%>] interface.
}
@(include-previously-extracted "main-extracts.rkt" #rx"^panel:") @(include-previously-extracted "main-extracts.rkt" #rx"^panel:")

2
collects/stepper/stepper-tool.rkt
View File

@ -173,7 +173,7 @@
(define/public (get-stepper-button) stepper-button) (define/public (get-stepper-button) stepper-button)
(define stepper-button-parent-panel (define stepper-button-parent-panel
(new horizontal-panel% (new frame:panel:horizontal-discrete-sizes%
[parent (get-button-panel)] [parent (get-button-panel)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])) [stretchable-height #f]))