Adjust DrRacket so the window can get narrower
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
parent
a45f94b58b
commit
993cd40208
|
|
@ -83,9 +83,10 @@
|
|||
(sort-toolbar-buttons-panel)))
|
||||
(super-new)
|
||||
(inherit get-button-panel)
|
||||
(set! toolbar-button-panel (new horizontal-panel%
|
||||
(set! toolbar-button-panel (new panel:horizontal-discrete-sizes%
|
||||
[parent (get-button-panel)]
|
||||
[stretchable-width #f]))
|
||||
[alignment '(right center)]
|
||||
[stretchable-width #t]))
|
||||
(after-initialized)
|
||||
(set! after-initialized void)
|
||||
|
||||
|
|
|
|||
|
|
@ -55,8 +55,6 @@ module browser threading seems wrong.
|
|||
(define show-planet-paths (string-constant module-browser-show-planet-paths/short))
|
||||
(define refresh (string-constant module-browser-refresh))
|
||||
|
||||
(define define-button-long-label "(define ...)")
|
||||
|
||||
(define oprintf
|
||||
(let ([op (current-output-port)])
|
||||
(λ args
|
||||
|
|
@ -1896,7 +1894,8 @@ module browser threading seems wrong.
|
|||
(let loop ([obj button-panel])
|
||||
(when (is-a? obj area-container<%>)
|
||||
(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?))
|
||||
(send obj set-orientation (not vertical?))))
|
||||
(for-each loop (send obj get-children))))
|
||||
|
|
@ -4372,7 +4371,10 @@ module browser threading seems wrong.
|
|||
[define teachpack-items null]
|
||||
[define break-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-break-button) break-button)
|
||||
(define/public (get-button-panel) button-panel)
|
||||
|
|
@ -4454,14 +4456,9 @@ module browser threading seems wrong.
|
|||
[label (string-constant break-button-label)]))
|
||||
(register-toolbar-button break-button #:number 101)
|
||||
|
||||
(send button-panel stretchable-height #f)
|
||||
(send button-panel stretchable-width #f)
|
||||
|
||||
(send top-panel change-children
|
||||
(λ (l)
|
||||
(list name-panel save-button
|
||||
(make-object vertical-panel% top-panel) ;; spacer
|
||||
button-panel)))
|
||||
(list name-panel save-button button-panel)))
|
||||
|
||||
(send top-panel stretchable-height #f)
|
||||
(inherit get-label)
|
||||
|
|
@ -4816,7 +4813,7 @@ module browser threading seems wrong.
|
|||
(string-constant no-full-name-since-not-saved)])
|
||||
|
||||
(inherit set-allow-shrinking)
|
||||
(set-allow-shrinking 100)))
|
||||
(set-allow-shrinking 50)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1124,7 +1124,7 @@
|
|||
[extra-menu-items (λ (menu) (add-line-number-menu-items menu))]))
|
||||
(define position-canvas (new position-canvas%
|
||||
[parent position-parent]
|
||||
[init-width "000:00-000:00"]))
|
||||
[init-width "1:1"]))
|
||||
(define/private (change-position-edit-contents str)
|
||||
(send position-canvas set-str str))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,14 @@
|
|||
#lang racket/unit
|
||||
#lang racket/base
|
||||
|
||||
(require racket/class
|
||||
racket/list
|
||||
"sig.rkt"
|
||||
mred/mred-sig)
|
||||
(require racket/class
|
||||
racket/list
|
||||
racket/unit
|
||||
"sig.rkt"
|
||||
mred/mred-sig
|
||||
mrlib/switchable-button)
|
||||
(provide panel@)
|
||||
|
||||
(define-unit panel@
|
||||
(import [prefix icon: framework:icon^]
|
||||
mred^)
|
||||
(export framework:panel^)
|
||||
|
|
@ -634,6 +638,261 @@
|
|||
;; canvas (widget -> editor) -> editor
|
||||
(define/public (split-vertical canvas maker)
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -60,7 +60,13 @@
|
|||
horizontal-dragable%
|
||||
|
||||
splitter<%>
|
||||
splitter-mixin))
|
||||
splitter-mixin
|
||||
|
||||
discrete-sizes<%>
|
||||
discrete-child<%>
|
||||
discrete-sizes-mixin
|
||||
horizontal-discrete-sizes%
|
||||
vertical-discrete-sizes%))
|
||||
(define-signature panel^ extends panel-class^
|
||||
(dragable-container-size
|
||||
dragable-place-children))
|
||||
|
|
|
|||
|
|
@ -1391,7 +1391,7 @@
|
|||
(label (string-constant debug-tool-button-name))
|
||||
(bitmap debug-bitmap)
|
||||
(alternate-bitmap small-debug-bitmap)
|
||||
(parent (new vertical-pane%
|
||||
(parent (new panel:horizontal-discrete-sizes%
|
||||
[parent (get-button-panel)]
|
||||
[alignment '(center center)]))
|
||||
(callback (λ (button) (debug-callback)))))
|
||||
|
|
@ -1526,9 +1526,9 @@
|
|||
(send (send debug-button get-parent) delete-child debug-button)))))
|
||||
|
||||
(send (get-button-panel) change-children
|
||||
(lambda (_)
|
||||
(lambda (children)
|
||||
(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:
|
||||
(check-current-language-for-debugger)))
|
||||
|
|
|
|||
|
|
@ -783,7 +783,7 @@
|
|||
(super help-menu:after-about menu))
|
||||
|
||||
(define client-panel
|
||||
(new vertical-pane% (parent (get-button-panel))))
|
||||
(new panel:vertical-discrete-sizes% (parent (get-button-panel))))
|
||||
|
||||
(define client-button
|
||||
(new switchable-button%
|
||||
|
|
|
|||
|
|
@ -127,10 +127,8 @@
|
|||
get-current-tab)
|
||||
|
||||
(define macro-debug-panel
|
||||
(new horizontal-pane%
|
||||
(parent (get-button-panel))
|
||||
(stretchable-height #f)
|
||||
(stretchable-width #f)))
|
||||
(new panel:horizontal-discrete-sizes%
|
||||
(parent (get-button-panel))))
|
||||
(define macro-debug-button
|
||||
(new switchable-button%
|
||||
(label macro-stepper-button-label)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.rkt" (for-label mrlib/switchable-button))
|
||||
@(require "common.rkt" (for-label mrlib/switchable-button framework))
|
||||
|
||||
@title{Switchable Button}
|
||||
|
||||
|
|
@ -12,21 +12,32 @@
|
|||
display of just the icon and a display with the
|
||||
label and the icon side-by-side.
|
||||
|
||||
@defconstructor/auto-super[([label string?]
|
||||
[callback (-> (is-a?/c switchable-button%) any/c)]
|
||||
The @racket[panel:discrete-sizes-mixin] explicitly
|
||||
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%)]
|
||||
[callback (-> (is-a?/c switchable-button%) any/c)]
|
||||
[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
|
||||
is pressed. The @racket[string] and @racket[bitmap] are
|
||||
is pressed. The @racket[label] and @racket[bitmap] are
|
||||
used as discussed above.
|
||||
|
||||
If @racket[alternate-bitmap] is supplied, then it is used
|
||||
when the button is switched to the view that just shows the bitmap.
|
||||
If it is not supplied, both modes show the same 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 @racket[bitmap].
|
||||
|
||||
If the @racket[vertical-tight?] argument is @racket[#t], then the button takes up
|
||||
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?]{
|
||||
|
|
@ -40,4 +51,19 @@
|
|||
@defmethod[(get-button-label) string?]{
|
||||
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]).
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require scheme/gui/base
|
||||
scheme/class)
|
||||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class)
|
||||
|
||||
(provide switchable-button%)
|
||||
(define gap 4) ;; space between the text and the icon
|
||||
|
|
@ -57,7 +57,8 @@
|
|||
bitmap
|
||||
callback
|
||||
[alternate-bitmap bitmap]
|
||||
[vertical-tight? #f])
|
||||
[vertical-tight? #f]
|
||||
[min-width-includes-label? #f])
|
||||
|
||||
(define/public (get-button-label) label)
|
||||
|
||||
|
|
@ -206,13 +207,13 @@
|
|||
;; Draw background. Use alpha blending if it can work,
|
||||
;; otherwise fall back to a suitable color.
|
||||
(let ([color (cond
|
||||
[disabled? #f]
|
||||
[in? (if (eq? (send dc get-smoothing) 'aligned)
|
||||
(if down? 0.5 0.2)
|
||||
(if down?
|
||||
half-gray
|
||||
one-fifth-gray))]
|
||||
[else #f])])
|
||||
[disabled? #f]
|
||||
[in? (if (eq? (send dc get-smoothing) 'aligned)
|
||||
(if down? 0.5 0.2)
|
||||
(if down?
|
||||
half-gray
|
||||
one-fifth-gray))]
|
||||
[else #f])])
|
||||
(when color
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc set-brush (if (number? color) "black" color) 'solid)
|
||||
|
|
@ -232,14 +233,19 @@
|
|||
(send dc set-alpha .5))
|
||||
|
||||
(cond
|
||||
[with-label?
|
||||
(let-values ([(tw th _1 _2) (send dc get-text-extent label)])
|
||||
(let ([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)))))]
|
||||
[with-label?
|
||||
(cond
|
||||
[(<= cw (get-small-width))
|
||||
(draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2))
|
||||
(- (/ ch 2) (/ (send bitmap get-height) 2)))]
|
||||
[else
|
||||
(define-values (tw th _1 _2) (send dc get-text-extent label))
|
||||
(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
|
||||
(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)))])
|
||||
|
|
@ -268,22 +274,53 @@
|
|||
(refresh)))
|
||||
|
||||
(define/private (update-sizes)
|
||||
(let ([dc (get-dc)])
|
||||
(cond
|
||||
[with-label?
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent label normal-control-font)])
|
||||
(do-w/h (+ w gap (send bitmap get-width) rhs-pad)
|
||||
(max h (send bitmap get-height))))]
|
||||
[else
|
||||
(do-w/h (send alternate-bitmap get-width)
|
||||
(send alternate-bitmap get-height))])))
|
||||
(define dc (get-dc))
|
||||
(define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font))
|
||||
(define h
|
||||
(inexact->exact
|
||||
(floor
|
||||
(+ (max th
|
||||
(send alternate-bitmap get-height)
|
||||
(send 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)
|
||||
(let ([w (floor (inexact->exact w))]
|
||||
[h (floor (inexact->exact h))])
|
||||
(min-width (+ w w-circle-space margin margin))
|
||||
(min-height (+ h h-circle-space margin margin
|
||||
(if vertical-tight? -6 0)))))
|
||||
(define/public (get-large-width)
|
||||
(define dc (get-dc))
|
||||
(define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font))
|
||||
(inexact->exact
|
||||
(floor
|
||||
(+ (+ 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)])
|
||||
(send (get-dc) set-smoothing 'aligned)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual scribble/extract)
|
||||
@(require (for-label framework))
|
||||
@(require (for-label scheme/gui))
|
||||
@(require (for-label framework mrlib/switchable-button racket/gui))
|
||||
@title{Panel}
|
||||
|
||||
@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:")
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@
|
|||
(define/public (get-stepper-button) stepper-button)
|
||||
|
||||
(define stepper-button-parent-panel
|
||||
(new horizontal-panel%
|
||||
(new frame:panel:horizontal-discrete-sizes%
|
||||
[parent (get-button-panel)]
|
||||
[stretchable-width #f]
|
||||
[stretchable-height #f]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user