From 241bb79cb0b671505e7d8811125d708d088d887c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 Jan 2011 13:25:22 -0700 Subject: [PATCH] allow a button% to have both a string and a bitmap for its label --- collects/games/main.rkt | 3 +- collects/mred/private/check.rkt | 13 ++++++ collects/mred/private/mritem.rkt | 22 ++++++--- collects/mred/private/wx/cocoa/button.rkt | 30 +++++++++++-- collects/mred/private/wx/gtk/button.rkt | 41 ++++++++++++++--- collects/scribblings/gui/button-class.scrbl | 21 ++++++--- collects/scribblings/gui/window-intf.scrbl | 20 ++++++--- collects/tests/gracket/item.rkt | 50 +++++++++++++++++++++ 8 files changed, 170 insertions(+), 30 deletions(-) diff --git a/collects/games/main.rkt b/collects/games/main.rkt index 0679dc8e19..89564a79d9 100644 --- a/collects/games/main.rkt +++ b/collects/games/main.rkt @@ -87,8 +87,7 @@ (define buttons (map (lambda (game) (new button% - [label ((bitmap-label-maker (game-name game) (game-icon game)) - panel)] + [label (list (read-bitmap (game-icon game)) (game-name game) 'left)] [parent panel] [callback (lambda _ (run-game game))])) games)) diff --git a/collects/mred/private/check.rkt b/collects/mred/private/check.rkt index 717d099cf5..41d781ce2a 100644 --- a/collects/mred/private/check.rkt +++ b/collects/mred/private/check.rkt @@ -146,6 +146,19 @@ (unless (or (label-string? label) (is-a? label wx:bitmap%)) (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label))) + (define (check-label-string-or-bitmap-or-both who label) + (unless (or (label-string? label) (is-a? label wx:bitmap%) + (and (list? label) + (= 3 (length label)) + (is-a? (car label) wx:bitmap%) + (label-string? (cadr label)) + (memq (caddr label) '(left right top bottom)))) + (raise-type-error (who->name who) + (string-append + "string (up to 200 characters), bitmap% object, or list of bitmap%, " + "string, and image-placement symbol ('left, 'right, 'top, or 'bottom)") + label))) + (define (check-label-string-or-bitmap/false who label) (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%)) (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label))) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 0302d72b08..a948d4615e 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -58,10 +58,16 @@ ;; for keyword use [font no-val]) (rename [super-set-label set-label]) - (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)]) + (private-field [label lbl][callback cb] + [can-bitmap? (or (lbl . is-a? . wx:bitmap%) + (pair? lbl))] + [can-string? (or (string? lbl) + (pair? lbl))]) (override [get-label (lambda () label)] - [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] + [get-plain-label (lambda () + (let ([label (if (pair? label) (cadr label) label)]) + (and (string? label) (wx:label->plain-label label))))] [set-label (entry-point (lambda (l) ((label-checker) @@ -69,12 +75,16 @@ (let ([l (if (string? l) (string->immutable-string l) l)]) - (when (or (and is-bitmap? + (when (or (and can-bitmap? (l . is-a? . wx:bitmap%)) - (and (not is-bitmap?) + (and can-string? (string? l))) (send wx set-label l) - (set! label l)))))]) + (if (pair? label) + (if (string? l) + (set! label (list (car label) l (caddr label))) + (set! label (list l (cadr label) (caddr label)))) + (set! label l))))))]) (public [hidden-child? (lambda () #f)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method @@ -210,7 +220,7 @@ [label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method (sequence (let ([cwho '(constructor button)]) - (check-label-string-or-bitmap cwho label) + (check-label-string-or-bitmap-or-both cwho label) (check-container-parent cwho parent) (check-callback cwho callback) (check-style cwho #f '(border deleted) style) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index cf9a0657a5..3e15383957 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -32,6 +32,11 @@ (-a _void (clicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked))))) +(define NSImageLeft 2) +(define NSImageRight 3) +(define NSImageBelow 4) +(define NSImageAbove 5) + (defclass core-button% item% (init parent cb label x y w h style font [button-type #f]) @@ -57,11 +62,21 @@ [else (if button-type (tellv cocoa setTitle: #:type _NSString "") - (tellv cocoa setImage: (bitmap->image label)))]) + (begin + (when (pair? label) + (tellv cocoa setTitle: #:type _NSString (cadr label)) + (tellv cocoa setImagePosition: #:type _NSInteger + (case (caddr label) + [(left) NSImageLeft] + [(right) NSImageRight] + [(top) NSImageAbove] + [(bottom) NSImageBelow]))) + (tellv cocoa setImage: (bitmap->image (if (pair? label) (car label) label)))))]) (init-font cocoa font) (tellv cocoa sizeToFit) (when (and (eq? event-type 'button) - (string? label)) + (or (string? label) + (pair? label))) (when font (let ([n (send font get-point-size)]) ;; If the font is small, adjust the control size: @@ -85,10 +100,19 @@ (NSSize-height (NSRect-size frame))))))) cocoa)) + (when (pair? label) + ;; It looks better to add extra padding around the button: + (let ([f (tell #:type _NSRect button-cocoa frame)]) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect + (NSRect-origin f) + (make-NSSize (+ (NSSize-width (NSRect-size f)) 2) + (+ (NSSize-height (NSRect-size f)) 4)))))) + (define-values (cocoa image-cocoa) (if (and button-type (not (string? label))) - ;; Check-box image: need an view to join a button and an image view: + ;; Check-box image: need a view to join a button and an image view: ;; (Could we use the NSImageButtonCell from the radio-box implementation ;; instead?) (let* ([frame (tell #:type _NSRect button-cocoa frame)] diff --git a/collects/mred/private/wx/gtk/button.rkt b/collects/mred/private/wx/gtk/button.rkt index e04ee2a0ca..561a304d19 100644 --- a/collects/mred/private/wx/gtk/button.rkt +++ b/collects/mred/private/wx/gtk/button.rkt @@ -22,6 +22,13 @@ (define-gtk gtk_button_new (_fun -> _GtkWidget)) (define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void)) +(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void)) +(define-gtk gtk_button_set_image_position (_fun _GtkWidget _int -> _void)) + +(define GTK_POS_LEFT 0) +(define GTK_POS_RIGHT 1) +(define GTK_POS_TOP 2) +(define GTK_POS_BOTTOM 3) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget)) @@ -47,18 +54,35 @@ (as-gtk-allocation (gtk_new_with_mnemonic (or (mnemonic-string label) "")))] [else - (let ([pixbuf (bitmap->pixbuf label)]) + (let ([pixbuf (bitmap->pixbuf (if (pair? label) + (car label) + label))]) (atomically - (let ([gtk (as-gtk-allocation (gtk_new))] + (let ([gtk (if (pair? label) + (as-gtk-allocation (gtk_new_with_mnemonic (cadr label))) + (as-gtk-allocation (gtk_new)))] [image-gtk (gtk_image_new_from_pixbuf pixbuf)]) (release-pixbuf pixbuf) - (gtk_container_add gtk image-gtk) - (gtk_widget_show image-gtk) + (if (pair? label) + (begin + (gtk_button_set_image gtk image-gtk) + (gtk_button_set_image_position + gtk + (case (caddr label) + [(left) GTK_POS_LEFT] + [(right) GTK_POS_RIGHT] + [(top) GTK_POS_TOP] + [(bottom) GTK_POS_BOTTOM]))) + (begin + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk))) gtk)))])] [callback cb] [font font] [no-show? (memq 'deleted style)]) (define gtk (get-gtk)) + + (define both-labels? (pair? label)) (when (eq? event-type 'button) (set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk) @@ -92,9 +116,12 @@ (atomically (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)]) (release-pixbuf pixbuf) - (gtk_container_remove gtk (gtk_bin_get_child gtk)) - (gtk_container_add gtk image-gtk) - (gtk_widget_show image-gtk))))])) + (if both-labels? + (gtk_button_set_image gtk image-gtk) + (begin + (gtk_container_remove gtk (gtk_bin_get_child gtk)) + (gtk_container_add gtk image-gtk) + (gtk_widget_show image-gtk))))))])) (define/public (set-border on?) (gtk_window_set_default (get-window-gtk) (if on? gtk #f)))) diff --git a/collects/scribblings/gui/button-class.scrbl b/collects/scribblings/gui/button-class.scrbl index fc145c383c..c41cb2ed9b 100644 --- a/collects/scribblings/gui/button-class.scrbl +++ b/collects/scribblings/gui/button-class.scrbl @@ -7,7 +7,11 @@ Whenever a button is clicked by the user, the button's callback procedure is invoked. A callback procedure is provided as an initialization argument when each button is created. -@defconstructor[([label (or/c label-string? (is-a?/c bitmap%))] +@defconstructor[([label (or/c label-string? + (is-a?/c bitmap%) + (list/c (is-a?/c bitmap%) + label-string? + (one-of/c 'left 'top 'right 'bottom)))] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) (is-a?/c panel%) (is-a?/c pane%))] [callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))] @@ -21,10 +25,13 @@ Whenever a button is clicked by the user, the button's callback [stretchable-width any/c #f] [stretchable-height any/c #f])]{ -Creates a button with a string or bitmap label. - @bitmaplabeluse[label] +Creates a button with a string label, bitmap label, or both. + @bitmaplabeluse[label] If @racket[label] is a list, then + the button has both a bitmap and string label, and the + symbol @racket['left], @racket['top], @racket['right], or @racket['bottom] + specifies the location of the image relative to the text on the button. -If @litchar{&} occurs in @scheme[label] (when @scheme[label] is a +If @litchar{&} occurs in @scheme[label] (when @scheme[label] includes a string), it is specially parsed; under Windows and X, the character following @litchar{&} is underlined in the displayed control to indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are @@ -56,7 +63,8 @@ on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button} @defmethod[#:mode override - (set-label [label (or/c label-string? (is-a?/c bitmap%))]) + (set-label [label (or/c label-string? + (is-a?/c bitmap%))]) void?]{ The same as @xmethod[window<%> set-label] when @scheme[label] is a @@ -65,5 +73,8 @@ The same as @xmethod[window<%> set-label] when @scheme[label] is a Otherwise, sets the bitmap label for a bitmap button. @bitmaplabeluseisbm[label] @|bitmapiforiglabel| +If the button has both a string and a bitmap label, then either can be + set using @method[button% set-label]. + }} diff --git a/collects/scribblings/gui/window-intf.scrbl b/collects/scribblings/gui/window-intf.scrbl index 668d7ee405..cef88ece6f 100644 --- a/collects/scribblings/gui/window-intf.scrbl +++ b/collects/scribblings/gui/window-intf.scrbl @@ -98,7 +98,7 @@ See also @defmethod[(get-cursor) - (or/c (is-a?/c cursor%) false/c)]{ + (or/c (is-a?/c cursor%) #f)]{ Returns the window's cursor, or @scheme[#f] if this window's cursor defaults to the parent's cursor. See @@ -141,8 +141,13 @@ See also } @defmethod[(get-label) - (or/c label-string? (is-a?/c bitmap%) - (one-of/c 'app 'caution 'stop) false/c)]{ + (or/c label-string? + (is-a?/c bitmap%) + (one-of/c 'app 'caution 'stop) + (list/c (is-a?/c bitmap%) + label-string? + (one-of/c 'left 'top 'right 'bottom)) + #f)]{ Gets a window's label, if any. Control windows generally display their label in some way. Frames and dialogs display their label as a window @@ -151,9 +156,10 @@ Gets a window's label, if any. Control windows generally display their have bitmap labels (only when they are created with bitmap labels), but all other windows have string labels. In addition, a message label can be an icon symbol @scheme['app], @scheme['caution], or - @scheme['stop]. + @scheme['stop], and a button can have both a bitmap label and a + string label (along with a position for the bitmap). -The label string may contain @litchar{&}s, which serve as +A label string may contain @litchar{&}s, which serve as keyboard navigation annotations for controls under Windows and X. The ampersands are not part of the displayed label of a control; instead, ampersands are removed in the displayed label (under all platforms), @@ -169,7 +175,7 @@ If the window does not have a label, @scheme[#f] is returned. @defmethod[(get-plain-label) - (or/c string false/c)]{ + (or/c string #f)]{ Like @method[window<%> get-label], except that ampersands in the label are removed. If the window has @@ -467,7 +473,7 @@ Enqueues an event to repaint the window. } -@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)]) +@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)]) void?]{ Sets the window's cursor. Providing @scheme[#f] instead of a cursor diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 493bfedc99..bd0db56051 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1235,6 +1235,55 @@ (instructions p "button-steps.txt") (send f show #t)) +(define (image-button-frame) + (define f (make-frame frame% "Image Button Test")) + (define pt (make-object vertical-panel% f)) + (define pm (make-object horizontal-panel% f)) + (define pb (make-object vertical-panel% f)) + (define pc (make-object horizontal-panel% f)) + (define bt (new button% [parent pt] + [label (list (read-bitmap + (collection-file-path "foot.png" "icons")) + "Top" + 'top)])) + (define bl (new button% [parent pm] + [label (list (read-bitmap + (collection-file-path "b-wait.png" "icons")) + "Left" + 'left)])) + (define br (new button% [parent pm] + [label (list (read-bitmap + (collection-file-path "b-run.png" "icons")) + "Right" + 'right)])) + (define bb (new button% [parent pb] + [label (list (read-bitmap + (collection-file-path "bug09.png" "icons")) + "Bottom" + 'bottom)])) + (new button% [parent pc] + [label "Strings"] + [callback (lambda (b e) + (for ([b (in-list (list bt bl br bb))]) + (send b set-label (list->string + (reverse + (string->list + (cadr (send b get-label))))))))]) + (new button% [parent pc] + [label "Bitmaps"] + [callback (lambda (b e) + (for ([b (in-list (list bt bl br bb))]) + (send b set-label (let ([bm (car (send b get-label))]) + (let* ([bm2 (make-bitmap (send bm get-width) + (send bm get-height))] + [dc (make-object bitmap-dc% bm2)]) + (send dc scale 1 -1) + (send dc translate 0 (send bm get-height)) + (send dc draw-bitmap bm 0 0) + (send dc set-bitmap #f) + bm2)))))]) + (send f show #t)) + (define (checkbox-frame) (define f (make-frame frame% "Checkbox Test")) (define p f) @@ -2223,6 +2272,7 @@ (make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null))) (make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border)))) (make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null))) +(make-object button% "Make Image Buttons" bp (lambda (b e) (image-button-frame))) (define crp (make-object horizontal-pane% ap)) (send crp stretchable-height #f) (make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))