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

allow a button% to have both a string and a bitmap for its label

Browse Source
This commit is contained in:
Matthew Flatt 2011-01-01 13:25:22 -07:00
parent a916f1af42
commit 241bb79cb0
8 changed files with 170 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/games/main.rkt
View File

@ -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))

13
collects/mred/private/check.rkt
View File

@ -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)))

22
collects/mred/private/mritem.rkt
View File

@ -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)

30
collects/mred/private/wx/cocoa/button.rkt
View File

@ -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)]

41
collects/mred/private/wx/gtk/button.rkt
View File

@ -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,19 +54,36 @@
(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)
GTK_CAN_DEFAULT)))
@ -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))))

21
collects/scribblings/gui/button-class.scrbl
View File

@ -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].
}}

20
collects/scribblings/gui/window-intf.scrbl
View File

@ -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

50
collects/tests/gracket/item.rkt
View File

@ -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)))