993cd40208
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
387 lines
14 KiB
Racket
387 lines
14 KiB
Racket
#lang racket/base
|
|
(require racket/gui/base
|
|
racket/class)
|
|
|
|
(provide switchable-button%)
|
|
(define gap 4) ;; space between the text and the icon
|
|
(define margin 2)
|
|
(define w-circle-space 6)
|
|
(define h-circle-space 6)
|
|
(define rhs-pad 2) ;; extra space outside the bitmap, but inside the mouse highlighting (on the right)
|
|
|
|
(define half-gray (make-object color% 127 127 127))
|
|
(define one-fifth-gray (make-object color% 200 200 200))
|
|
|
|
(define yellow-message%
|
|
(class canvas%
|
|
(init-field label)
|
|
|
|
(define/override (on-paint)
|
|
(let ([dc (get-dc)])
|
|
(let ([pen (send dc get-pen)]
|
|
[brush (send dc get-brush)]
|
|
[font (send dc get-font)]
|
|
[yellow (make-object color% 255 255 200)])
|
|
|
|
(send dc set-pen yellow 1 'transparent)
|
|
(send dc set-brush yellow 'solid)
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(send dc draw-rectangle 0 0 cw ch)
|
|
|
|
(send dc set-font small-control-font)
|
|
|
|
(let-values ([(tw th _1 _2) (send dc get-text-extent label)])
|
|
(send dc draw-text
|
|
label
|
|
(- (/ cw 2) (/ tw 2))
|
|
(- (/ ch 2) (/ th 2)))))
|
|
|
|
(send dc set-pen pen)
|
|
(send dc set-brush brush)
|
|
(send dc set-font font))))
|
|
|
|
(define/override (on-event evt)
|
|
(show #f))
|
|
|
|
(inherit stretchable-width stretchable-height
|
|
min-width min-height
|
|
get-client-size get-dc show)
|
|
(super-new)
|
|
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent label small-control-font)])
|
|
(min-width (floor (inexact->exact (+ tw 4))))
|
|
(min-height (floor (inexact->exact (+ th 4)))))))
|
|
|
|
(define switchable-button%
|
|
(class canvas%
|
|
(init-field label
|
|
bitmap
|
|
callback
|
|
[alternate-bitmap bitmap]
|
|
[vertical-tight? #f]
|
|
[min-width-includes-label? #f])
|
|
|
|
(define/public (get-button-label) label)
|
|
|
|
(when (and (is-a? label bitmap%)
|
|
(not (send label ok?)))
|
|
(error 'switchable-button% "label bitmap is not ok?"))
|
|
|
|
(define/override (get-label) label)
|
|
|
|
(define disable-bitmap (make-dull-mask bitmap))
|
|
|
|
(define alternate-disable-bitmap
|
|
(if (eq? bitmap alternate-bitmap)
|
|
disable-bitmap
|
|
(make-dull-mask alternate-bitmap)))
|
|
|
|
(inherit get-dc min-width min-height get-client-size refresh
|
|
client->screen)
|
|
|
|
(define down? #f)
|
|
(define in? #f)
|
|
(define disabled? #f)
|
|
(define with-label? (string? label))
|
|
|
|
(define/override (enable e?)
|
|
(unless (equal? disabled? (not e?))
|
|
(set! disabled? (not e?))
|
|
(set! down? #f)
|
|
(set! in? #f)
|
|
(refresh)))
|
|
(define/override (is-enabled?) (not disabled?))
|
|
|
|
(define/override (on-superwindow-show show?)
|
|
(unless show?
|
|
(set! in? #f)
|
|
(set! down? #f)
|
|
(update-float #f)
|
|
(refresh))
|
|
(super on-superwindow-show show?))
|
|
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(send evt button-down? 'left)
|
|
(set! down? #t)
|
|
(set! in? #t)
|
|
(refresh)
|
|
(update-float #t)]
|
|
[(send evt button-up? 'left)
|
|
(set! down? #f)
|
|
(update-in evt)
|
|
(refresh)
|
|
(when (and in?
|
|
(not disabled?))
|
|
(update-float #f)
|
|
(callback this))]
|
|
[(send evt entering?)
|
|
(set! in? #t)
|
|
(update-float #t)
|
|
(unless disabled?
|
|
(refresh))]
|
|
[(send evt leaving?)
|
|
(set! in? #f)
|
|
(update-float #f)
|
|
(unless disabled?
|
|
(refresh))]
|
|
[(send evt moving?)
|
|
(update-in evt)]))
|
|
|
|
(define/public (command)
|
|
(callback this)
|
|
(void))
|
|
|
|
(define float-window #f)
|
|
(inherit get-width get-height)
|
|
(define timer (new timer%
|
|
[just-once? #t]
|
|
[notify-callback
|
|
(λ ()
|
|
(unless with-label?
|
|
(unless (equal? (send float-window is-shown?) in?)
|
|
(send float-window show in?)))
|
|
(set! timer-running? #f))]))
|
|
(define timer-running? #f)
|
|
|
|
(define/private (update-float new-value?)
|
|
(when label
|
|
(cond
|
|
[with-label?
|
|
(when float-window
|
|
(send float-window show #f))]
|
|
[else
|
|
(unless (and float-window
|
|
(equal? new-value? (send float-window is-shown?)))
|
|
(cond
|
|
[new-value?
|
|
(unless float-window
|
|
(set! float-window (new frame%
|
|
[label ""]
|
|
[style '(no-caption no-resize-border float)]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]))
|
|
(new yellow-message% [parent float-window] [label (or label "")]))
|
|
|
|
(send float-window reflow-container)
|
|
|
|
;; position the floating window
|
|
(let-values ([(dw dh) (get-display-size)]
|
|
[(x y) (client->screen (floor (get-width))
|
|
(floor
|
|
(- (/ (get-height) 2)
|
|
(/ (send float-window get-height) 2))))]
|
|
[(dx dy) (get-display-left-top-inset)])
|
|
(let ([rhs-x (- x dx)]
|
|
[rhs-y (- y dy)])
|
|
(cond
|
|
[(< (+ rhs-x (send float-window get-width)) dw)
|
|
(send float-window move rhs-x rhs-y)]
|
|
[else
|
|
(send float-window move
|
|
(- rhs-x (send float-window get-width) (get-width))
|
|
rhs-y)])))
|
|
(unless timer-running?
|
|
(set! timer-running? #t)
|
|
(send timer start 500 #t))]
|
|
[else
|
|
(when float-window
|
|
(send float-window show #f))]))])))
|
|
|
|
(define/private (update-in evt)
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(let ([new-in?
|
|
(and (<= 0 (send evt get-x) cw)
|
|
(<= 0 (send evt get-y) ch))])
|
|
(unless (equal? new-in? in?)
|
|
(set! in? new-in?)
|
|
(refresh))
|
|
(update-float new-in?))))
|
|
|
|
(define/override (on-paint)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(let ([alpha (send dc get-alpha)]
|
|
[pen (send dc get-pen)]
|
|
[brush (send dc get-brush)])
|
|
|
|
;; 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])])
|
|
(when color
|
|
(send dc set-pen "black" 1 'transparent)
|
|
(send dc set-brush (if (number? color) "black" color) 'solid)
|
|
(when (number? color)
|
|
(send dc set-alpha color))
|
|
(send dc draw-rounded-rectangle
|
|
margin
|
|
margin
|
|
(max 0 (- cw margin margin))
|
|
(max 0 (- ch margin margin)))
|
|
(when (number? color)
|
|
(send dc set-alpha alpha))))
|
|
|
|
(send dc set-font normal-control-font)
|
|
|
|
(when disabled?
|
|
(send dc set-alpha .5))
|
|
|
|
(cond
|
|
[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)))])
|
|
|
|
(send dc set-pen pen)
|
|
(send dc set-alpha alpha)
|
|
(send dc set-brush brush)))))
|
|
|
|
(define/private (draw-the-bitmap x y)
|
|
(let ([bm (if with-label? bitmap alternate-bitmap)])
|
|
(send (get-dc)
|
|
draw-bitmap
|
|
bm
|
|
x y
|
|
'solid
|
|
(send the-color-database find-color "black")
|
|
(if disabled?
|
|
(if with-label? disable-bitmap alternate-disable-bitmap)
|
|
(send bm get-loaded-mask)))))
|
|
|
|
(define/public (set-label-visible h?)
|
|
(unless (equal? with-label? h?)
|
|
(set! with-label? h?)
|
|
(update-sizes)
|
|
(update-float (and with-label? in?))
|
|
(refresh)))
|
|
|
|
(define/private (update-sizes)
|
|
(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/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)
|
|
|
|
(inherit stretchable-width stretchable-height)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f)
|
|
(inherit get-graphical-min-size)
|
|
(update-sizes)))
|
|
|
|
(define (make-dull-mask bitmap)
|
|
(let ([alpha-bm (send bitmap get-loaded-mask)])
|
|
(and alpha-bm
|
|
(let* ([w (send alpha-bm get-width)]
|
|
[h (send alpha-bm get-height)]
|
|
[disable-bm (make-object bitmap% w h)]
|
|
[pixels (make-bytes (* 4 w h))]
|
|
[bdc (make-object bitmap-dc% alpha-bm)])
|
|
(send bdc get-argb-pixels 0 0 w h pixels)
|
|
(let loop ([i 0])
|
|
(when (< i (* 4 w h))
|
|
(bytes-set! pixels i (- 255 (quotient (- 255 (bytes-ref pixels i)) 2)))
|
|
(loop (+ i 1))))
|
|
(send bdc set-bitmap disable-bm)
|
|
(send bdc set-argb-pixels 0 0 w h pixels)
|
|
(send bdc set-bitmap #f)
|
|
disable-bm))))
|
|
|
|
#;
|
|
(begin
|
|
(define f (new frame% [label ""]))
|
|
(define vp (new vertical-pane% [parent f]))
|
|
(define p (new horizontal-panel% [parent vp] [alignment '(right top)]))
|
|
|
|
(define label "Run")
|
|
(define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask))
|
|
(define foot (make-object bitmap% (build-path (collection-path "icons") "foot.png") 'png/mask))
|
|
(define foot-up (make-object bitmap% (build-path (collection-path "icons") "foot-up.png") 'png/mask))
|
|
|
|
(define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
|
|
(define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void]))
|
|
(define b3 (new switchable-button% [parent p] [label "Step"] [bitmap foot] [alternate-bitmap foot-up] [callback void]))
|
|
(define sb (new button% [parent p] [stretchable-width #t] [label "b"]))
|
|
(define swap-button
|
|
(new button%
|
|
[parent f]
|
|
[label "swap"]
|
|
[callback
|
|
(let ([state #t])
|
|
(λ (a b)
|
|
(set! state (not state))
|
|
(send b1 set-label-visible state)
|
|
(send b2 set-label-visible state)
|
|
(send b3 set-label-visible state)))]))
|
|
(define disable-button
|
|
(new button%
|
|
[parent f]
|
|
[label "disable"]
|
|
[callback
|
|
(λ (a b)
|
|
(send sb enable (not (send sb is-enabled?)))
|
|
(send b1 enable (not (send b1 is-enabled?))))]))
|
|
(send f show #t))
|