[plt-scheme] New label widget

Hi,

I hope it will be some use to some other people as well. I have made a new 
label widget which is able to change its size when the displayed text is
changed. If somebody knows how to do it in another way, please let me 
know.

The file below contains the class definition and a little example.
To run, type:          mred -r label.scm
It will show a little window with a label and a text-field. What you type
in the text-field will be displayed in the label, once you press Enter.
(I have only tested the outlook of it on Linux. Maybe it have to be 
tweaked for Windows.)

Enjoy.

					Peter Ivanyi

------------------------- label .scm -------------------------------
; -*- Scheme -*-

; This is the implementation of a simple label widget with resizing capability.
; The widget only displays a text, however it resizes itself when the text is changed
; to be able to show the full text. (It increases or reduces its size as per demand.)

; The widget is a subclass of the canvas% object and 
; it only overrides the on-paint event.

; Original idea is taken from the "name-message.ss" file.

(define label%
  (class canvas% ()
    (inherit get-parent get-dc get-client-size 
             min-width min-height
             stretchable-width stretchable-height)
    (override on-paint)

    ; initially no text is assigned to the label
    (init-field (text ""))

    ; method to change the text of the label
    ; the widget will be resized and push other widgets to the right !!!
    (define/public (set-label-text new-text)
      (unless (equal? text new-text)
        (set! text new-text)  ; set new text
        (update-min-sizes)    ; recalculate the size of the widget and set it
        (on-paint)))          ; redraw

    (define label-inset 1)
    (define black-color (make-object color% "BLACK"))

    ; the font to use for the text
    (define label-font
      (send the-font-list find-or-create-font
            12 'decorative 'normal 'normal #f))

    ; method to draw the text of the widget
    (define (draw-label dc text w h)
      ; background square to draw
      (send dc set-pen (send the-pen-list find-or-create-pen
                             (get-panel-background) 1 'solid))
      (send dc set-brush (send the-brush-list find-or-create-brush
                              (get-panel-background) 'solid))
      (send dc draw-rectangle 0 0 w h)
      
      ; draw text into the square
      (when text
        ; set colors, fonts, etc.
        (send dc set-text-foreground black-color)
        (send dc set-text-background (get-panel-background))
        (send dc set-font label-font)
        (send dc draw-text text
              (+ label-inset 1)
              (+ label-inset 1))))

    ; calculate the minimum size of the widget containing the text
    (define (calc-min-sizes dc text)
      (send dc set-font label-font)
      (let-values ([(w h a d) (send dc get-text-extent text label-font)])
        (let ([ans-w
               (+ label-inset
                  label-inset
                  1
                  (max 0 (inexact->exact (ceiling w))))]
              [ans-h
               (+ label-inset 
                  label-inset
                  1
                  (max 0 (inexact->exact (ceiling h))))])
          (values ans-w ans-h))))

    ; for the current value of text (private field) 
    ; - calculate the minimum size of the widget
    ; - set minimum values in the widget
    ; - notify parent, so it can rearrange widgets
    (define (update-min-sizes)
      (let-values ([(w h) (calc-min-sizes (get-dc) text)])
        (min-width w)
        (min-height h)
        (send (get-parent) reflow-container)))

    ; drawing method for label widget
    (define (on-paint)
      (let ([dc (get-dc)])
        (let-values ([(w h) (get-client-size)])
          (draw-label dc text w h))))

    (super-instantiate ())
    ; size update for initial field declaration
    (update-min-sizes)
    ; widget is not resizeable
    (stretchable-width #f)
    (stretchable-height #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; For testing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define window
  (new frame%
       (label "Test window")
       (border 10))
)

(define top
  (new horizontal-panel%
       (parent window))
)


(define mes
  (new label%
       (text "Init Hello")
       (parent top))
)

(define text1
  (new text-field%
       (label "")
       (parent top)
       (callback (lambda (text event)
                   (if (eq? (send event get-event-type) 'text-field-enter)
                     (begin
                       (send mes show #f)
                       (send mes set-label-text (send text1 get-value))
                       (send mes show #t)
                       (send text1 set-value "")
                     )))
       )
  )
)


(send window show #t)