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