switchable-button.rkt
1 #lang racket/base 2 (require racket/gui/base 3 racket/class 4 "private/panel-wob.rkt") 5 6 (provide switchable-button%) 7 (define gap 4) ;; space between the text and the icon 8 (define margin 2) 9 (define w-circle-space 6) 10 (define h-circle-space 6) 11 12 ;; extra space outside the bitmap, 13 ;; but inside the mouse highlighting (on the right) 14 (define rhs-pad 2) 15 16 (define half-gray (make-object color% 127 127 127)) 17 (define one-fifth-gray (make-object color% 200 200 200)) 18 19 (define yellow-message% 20 (class canvas% 21 (init-field label) 22 23 (define/override (on-paint) 24 (define dc (get-dc)) 25 (define pen (send dc get-pen)) 26 (define brush (send dc get-brush)) 27 (define font (send dc get-font)) 28 (define yellow (make-object color% 255 255 200)) 29 30 (send dc set-pen yellow 1 'transparent) 31 (send dc set-brush yellow 'solid) 32 (define-values (cw ch) (get-client-size)) 33 (send dc draw-rectangle 0 0 cw ch) 34 35 (send dc set-font small-control-font) 36 37 (define-values (tw th _1 _2) (send dc get-text-extent label)) 38 (send dc draw-text 39 label 40 (- (/ cw 2) (/ tw 2)) 41 (- (/ ch 2) (/ th 2))) 42 43 (send dc set-pen pen) 44 (send dc set-brush brush) 45 (send dc set-font font)) 46 47 (define/override (on-event evt) 48 (send (get-top-level-window) show #f)) 49 50 (inherit stretchable-width stretchable-height 51 min-width min-height 52 get-client-size get-dc 53 get-top-level-window) 54 (super-new) 55 (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent label small-control-font)]) 56 (min-width (floor (inexact->exact (+ tw 4)))) 57 (min-height (floor (inexact->exact (+ th 4))))))) 58 59 (define switchable-button% 60 (class canvas% 61 (init-field label 62 bitmap 63 callback 64 [alternate-bitmap bitmap] 65 [vertical-tight? #f] 66 [min-width-includes-label? #f]) 67 68 (define/public (get-button-label) label) 69 (define/override (set-label l) 70 (set! label l) 71 (update-sizes) 72 (refresh)) 73 74 (when (and (is-a? label bitmap%) 75 (not (send label ok?))) 76 (error 'switchable-button% "label bitmap is not ok?")) 77 78 (define/override (get-label) label) 79 80 (define disable-bitmap (make-dull-mask bitmap)) 81 82 (define alternate-disable-bitmap 83 (if (eq? bitmap alternate-bitmap) 84 disable-bitmap 85 (make-dull-mask alternate-bitmap))) 86 87 (inherit get-dc min-width min-height get-client-size refresh 88 client->screen) 89 90 (define down? #f) 91 (define in? #f) 92 (define disabled? #f) 93 (define has-label? (string? label)) 94 95 (define/override (enable e?) 96 (unless (equal? disabled? (not e?)) 97 (set! disabled? (not e?)) 98 (set! down? #f) 99 (set! in? #f) 100 (refresh))) 101 (define/override (is-enabled?) (not disabled?)) 102 103 (define/override (on-superwindow-show show?) 104 (unless show? 105 (set! in? #f) 106 (set! down? #f) 107 (update-float #f) 108 (refresh)) 109 (super on-superwindow-show show?)) 110 111 (define/override (on-event evt) 112 (cond 113 [(send evt button-down? 'left) 114 (set! down? #t) 115 (set! in? #t) 116 (refresh) 117 (update-float #t)] 118 [(send evt button-up? 'left) 119 (set! down? #f) 120 (update-in evt #t) 121 (refresh) 122 (when (and in? 123 (not disabled?)) 124 (update-float #f) 125 (callback this))] 126 [(send evt entering?) 127 (set! in? #t) 128 (update-float #t) 129 (unless disabled? 130 (refresh))] 131 [(send evt leaving?) 132 (set! in? #f) 133 (update-float #f) 134 (unless disabled? 135 (refresh))] 136 [else 137 (update-in evt)])) 138 139 (define/public (command) 140 (callback this) 141 (void)) 142 143 (define float-window #f) 144 (inherit get-width get-height) 145 (define timer (new timer% 146 [just-once? #t] 147 [notify-callback 148 (λ () 149 (unless has-label? 150 (unless (equal? (send float-window is-shown?) in?) 151 (send float-window show in?))) 152 (set! timer-running? #f))])) 153 (define timer-running? #f) 154 155 (define/private (update-float new-value?) 156 (when label 157 (cond 158 [has-label? 159 (when float-window 160 (send float-window show #f))] 161 [else 162 (unless (and float-window 163 (equal? new-value? (send float-window is-shown?))) 164 (cond 165 [new-value? 166 (unless float-window 167 (set! float-window (new frame% 168 [label ""] 169 [style '(no-caption no-resize-border float)] 170 [stretchable-width #f] 171 [stretchable-height #f])) 172 (new yellow-message% [parent float-window] [label (or label "")])) 173 174 (send float-window reflow-container) 175 176 ;; position the floating window 177 (define-values (dw dh) (get-display-size)) 178 (define-values (x y) (client->screen (floor (get-width)) 179 (floor 180 (- (/ (get-height) 2) 181 (/ (send float-window get-height) 2))))) 182 (define-values (dx dy) (get-display-left-top-inset)) 183 (define rhs-x (- x dx)) 184 (define rhs-y (- y dy)) 185 (cond 186 [(< (+ rhs-x (send float-window get-width)) dw) 187 (send float-window move rhs-x rhs-y)] 188 [else 189 (send float-window move 190 (- rhs-x (send float-window get-width) (get-width)) 191 rhs-y)]) 192 (unless timer-running? 193 (set! timer-running? #t) 194 (send timer start 500 #t))] 195 [else 196 (when float-window 197 (send float-window show #f))]))]))) 198 199 (define/private (update-in evt [dont-refresh? #f]) 200 (define-values (cw ch) (get-client-size)) 201 (define new-in? 202 (and (<= 0 (send evt get-x) cw) 203 (<= 0 (send evt get-y) ch))) 204 (unless dont-refresh? 205 (unless (equal? new-in? in?) 206 (set! in? new-in?) 207 (refresh))) 208 (update-float new-in?)) 209 210 (define/override (on-paint) 211 (define dc (get-dc)) 212 (define-values (cw ch) (get-client-size)) 213 (define alpha (send dc get-alpha)) 214 (define pen (send dc get-pen)) 215 (define text-foreground (send dc get-text-foreground)) 216 (define brush (send dc get-brush)) 217 218 ;; Draw background. Use alpha blending if it can work, 219 ;; otherwise fall back to a suitable color. 220 (define down-same-as-black-on-white? 221 (equal? down? 222 (not (white-on-black-panel-scheme?)))) 223 (define color 224 (cond 225 [disabled? #f] 226 [in? (if (equal? (send dc get-smoothing) 'aligned) 227 (if down-same-as-black-on-white? 0.5 0.2) 228 (if down-same-as-black-on-white? 229 half-gray 230 one-fifth-gray))] 231 [else #f])) 232 (when color 233 (send dc set-pen "black" 1 'transparent) 234 (send dc set-brush (if (number? color) 235 (get-label-foreground-color) 236 color) 'solid) 237 (when (number? color) 238 (send dc set-alpha color)) 239 (send dc draw-rounded-rectangle 240 margin 241 margin 242 (max 0 (- cw margin margin)) 243 (max 0 (- ch margin margin))) 244 (when (number? color) 245 (send dc set-alpha alpha))) 246 247 (send dc set-font normal-control-font) 248 249 (when disabled? 250 (send dc set-alpha .5)) 251 252 (cond 253 [has-label? 254 (cond 255 [(<= cw (get-small-width)) 256 (draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2)) 257 (- (/ ch 2) (/ (send bitmap get-height) 2)))] 258 [else 259 (define-values (tw th _1 _2) (send dc get-text-extent label)) 260 (define text-start (+ (/ cw 2) 261 (- (/ tw 2)) 262 (- (/ (send bitmap get-width) 2)) 263 (- rhs-pad))) 264 (send dc set-text-foreground (get-label-foreground-color)) 265 (send dc draw-text label text-start (- (/ ch 2) (/ th 2))) 266 (draw-the-bitmap (+ text-start tw gap) 267 (- (/ ch 2) (/ (send bitmap get-height) 2)))])] 268 [else 269 (draw-the-bitmap 270 (- (/ cw 2) 271 (/ (send (if has-label? bitmap alternate-bitmap) get-width) 272 2)) 273 (- (/ ch 2) 274 (/ (send (if has-label? bitmap alternate-bitmap) get-height) 275 2)))]) 276 277 (send dc set-pen pen) 278 (send dc set-alpha alpha) 279 (send dc set-brush brush) 280 (send dc set-text-foreground text-foreground)) 281 282 (define/private (draw-the-bitmap x y) 283 (define bm (if has-label? bitmap alternate-bitmap)) 284 (send (get-dc) 285 draw-bitmap 286 bm 287 x y 288 'solid 289 (send the-color-database find-color "black") 290 (if disabled? 291 (if has-label? disable-bitmap alternate-disable-bitmap) 292 (send bm get-loaded-mask)))) 293 294 (define/public (set-label-visible in-h?) 295 (define h? (and in-h? #t)) 296 (unless (equal? has-label? h?) 297 (set! has-label? h?) 298 (update-sizes) 299 (update-float (and has-label? in?)) 300 (refresh))) 301 (define/public (get-label-visible) has-label?) 302 303 (define/private (update-sizes) 304 (define dc (get-dc)) 305 (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font)) 306 (define h 307 (inexact->exact 308 (floor 309 (+ (max th 310 (send alternate-bitmap get-height) 311 (send bitmap get-height)) 312 h-circle-space margin margin 313 (if vertical-tight? -6 0))))) 314 (cond 315 [has-label? 316 (cond 317 [min-width-includes-label? 318 (min-width (get-large-width))] 319 [else 320 (min-width (get-small-width))]) 321 (min-height h)] 322 [else 323 (min-width (get-without-label-small-width)) 324 (min-height h)])) 325 326 (define/public (get-large-width) 327 (define dc (get-dc)) 328 (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font)) 329 (inexact->exact 330 (floor 331 (+ (+ tw gap (send bitmap get-width) rhs-pad) 332 w-circle-space 333 margin 334 margin)))) 335 336 (define/public (get-without-label-small-width) 337 (inexact->exact 338 (floor 339 (+ (send alternate-bitmap get-width) 340 w-circle-space 341 margin 342 margin)))) 343 344 (define/public (get-small-width) 345 (inexact->exact 346 (floor 347 (+ (send bitmap get-width) 348 w-circle-space 349 margin 350 margin)))) 351 352 (super-new [style '(transparent no-focus)]) 353 (send (get-dc) set-smoothing 'aligned) 354 355 (inherit stretchable-width stretchable-height) 356 (stretchable-width #f) 357 (stretchable-height #f) 358 (inherit get-graphical-min-size) 359 (update-sizes))) 360 361 (define (make-dull-mask bitmap) 362 (define alpha-bm (send bitmap get-loaded-mask)) 363 (cond 364 [alpha-bm 365 (define w (send alpha-bm get-width)) 366 (define h (send alpha-bm get-height)) 367 (define disable-bm (make-object bitmap% w h)) 368 (define pixels (make-bytes (* 4 w h))) 369 (define bdc (make-object bitmap-dc% alpha-bm)) 370 (send bdc get-argb-pixels 0 0 w h pixels) 371 (let loop ([i 0]) 372 (when (< i (* 4 w h)) 373 (bytes-set! pixels i (- 255 (quotient (- 255 (bytes-ref pixels i)) 2))) 374 (loop (+ i 1)))) 375 (send bdc set-bitmap disable-bm) 376 (send bdc set-argb-pixels 0 0 w h pixels) 377 (send bdc set-bitmap #f) 378 disable-bm] 379 [else #f])) 380 381 #; 382 (begin 383 (define f (new frame% [label ""])) 384 (define vp (new vertical-pane% [parent f])) 385 (define p (new horizontal-panel% [parent vp] [alignment '(right top)])) 386 387 (define label "Run") 388 (define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask)) 389 (define foot (make-object bitmap% (build-path (collection-path "icons") "foot.png") 'png/mask)) 390 (define foot-up 391 (make-object bitmap% (build-path (collection-path "icons") "foot-up.png") 'png/mask)) 392 393 (define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) 394 (define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) 395 (define b3 (new switchable-button% [parent p] [label "Step"] [bitmap foot] 396 [alternate-bitmap foot-up] 397 [callback void])) 398 (define sb (new button% [parent p] [stretchable-width #t] [label "b"])) 399 (define swap-button 400 (new button% 401 [parent f] 402 [label "swap"] 403 [callback 404 (define state #t) 405 (λ (a b) 406 (set! state (not state)) 407 (send b1 set-label-visible state) 408 (send b2 set-label-visible state) 409 (send b3 set-label-visible state))])) 410 (define disable-button 411 (new button% 412 [parent f] 413 [label "disable"] 414 [callback 415 (λ (a b) 416 (send sb enable (not (send sb is-enabled?))) 417 (send b1 enable (not (send b1 is-enabled?))))])) 418 (send f show #t))