[plt-scheme] Custom GUI's in Scheme
At Sun, 05 Dec 2004 19:37:04 -0600, "Arctic Fidelity" wrote:
> [...] wants to
> have a program with lot's of color, shadows, etc.
>
> The problem is that I can't find a way to do that with the MrEd
> tookbox, and I assume you can't. What's I'm looking for then, is a
> good way to create this application. I know that with other IDE's you
> can create your own objects, such as buttons that are bitmaps, etc.
> But I am at a loss of how to do it in PLT scheme.
You can derive from canvas% to create an arbitrary control from
scratch.
As an example, the code below creates a label-like control that paints
its label blue. (It's extracted from SirMail.) By overriding
`on-event', you can make a clickable button. See also "name-message.ss"
in the "mrlib" collection for another example.
(FWIW, button%s support bitmap labels, and in v299, the bitmap's mask
is used when drawing the button. So you could create a color-text label
in v299 by creating a bitmap for the label.)
Matthew
----------------------------------------
;; v208 doesn't have transparent canvases, so we have to
;; make an opaque one and paint the background with the panel color
(define v208? (regexp-match "^20" (version)))
(define new-mail-message%
(class canvas%
(inherit get-dc get-client-size get-parent
horiz-margin vert-margin)
(init-field [font (make-object font% 18 'default 'normal 'bold)])
(define message "<<unset>>")
(define/override (on-paint)
(let ([dc (get-dc)])
(send dc set-font font)
(send dc set-text-foreground (make-object color% "blue"))
(let-values ([(w h) (get-client-size)]
[(tw th ta td) (send dc get-text-extent message)])
(when v208?
(send dc set-pen (send the-pen-list find-or-create-pen
(get-panel-background) 1 'transparent))
(send dc set-brush (send the-brush-list find-or-create-brush
(get-panel-background) 'panel))
(send dc draw-rectangle 0 0 w h))
(send dc draw-text message
(- (/ w 2) (/ tw 2))
(- (/ h 2) (/ th 2))))))
(define/public (set-message n)
(set! message
(cond
[(n . <= . 50) "New Mail!"]
[(n . <= . 200) "New Mail"]
[else "New Mail!@#$%"]))
(update-min-size))
(inherit min-width min-height)
(define/private (update-min-size)
(let-values ([(w h d s) (send (get-dc) get-text-extent message font)])
(min-width (inexact->exact (ceiling w)))
(min-height (inexact->exact (ceiling h)))))
(if v208?
(super-new)
(super-new (style '(transparent))))
(update-min-size)
(inherit stretchable-width)
(horiz-margin 2)
(vert-margin 2)
(stretchable-width #f)))
(define f (make-object frame% "Test"))
(send (new new-mail-message% [parent f]) set-message 10)
(send f show #t)