Resizing fonts on window resize

schlenk, 19. July 2005: Answering a question on self-tcl.de [L1 ] i came up with this little demo. It shows how to dynamically resize a label with some text, when the window is resized:

 package require Tk
 package require math::interpolate

 proc createInterpolationTable {win font text} {
   set max [winfo vrootwidth $win]
   set oldsize [font configure $font -size]
   set xval [list]
   set yval [list]
   set x 0
   set size 2
   while {$x < $max} {
      font configure $font -size $size
      set x [font measure $font $text]
      lappend xval $x
      lappend yval $size
      incr size 4
   }
  font configure $font -size $oldsize
  return [list $xval $yval]
 }

 proc adjustFont {font width ipt} {
   set newSize [lindex [math::interpolate::neville [lindex $ipt 0] [lindex $ipt 1] $width] 0]
   font configure $font -size [expr {int($newSize)}]
 }

 proc configureBinding {font ipt win width heigth} {
    bind $win <Configure> {}
    adjustFont $font $width $ipt
    after idle [list bind $win <Configure> [list configureBinding title $ipt %W %w %h]]
 }

 font create title -family Verdana -size 10
 toplevel .test
 set txt "Some Title"
 set ipt [createInterpolationTable .test title $txt]
 label .test.l -text $txt -font title
 pack  .test.l -expand 1 -fill both
 wm geometry .test 400x300+0+0
 bind  .test.l <Configure> [list configureBinding title $ipt %W %w %h]

MHo - 2008-02-27: just tested on windows. After starting the program, I had no chance to klick anything: the window constantly flickers. Had to press Alt+F4 to cancel. Looks like the Configure-event is constantly fired...

fr - 2020-01-31: added first and last line in "proc configureBinding", initial size by "wm geometry .."

DDG - 2020-02-01: fix window name in proc configureBinding and added snit widget below

DDG - 2020-02-01: Here is a snit::widget dlabel where dlabel stands for dynamic label:

package require Tk
package require snit
package require math::interpolate

snit::widget  dlabel {
    component label
    option -text "Default"
    delegate method * to label
    delegate option * to label
    option -font ""
    constructor {args} {
        install label using ttk::label $win.lbl {*}$args
        $self configurelist $args
        if {$options(-font) eq ""} {
            set mfont [font create {*}[font configure TkDefaultFont]]
            $label configure -font $mfont
            set options(-font) $mfont
        }
        set ipt [$self createInterpolationTable $win $options(-font) [$self cget -text]]
        pack $label -side top -fill both -expand yes -padx 10 -pady 10
        bind  $label <Configure> [mymethod configureBinding $ipt %W %w %h] 
    }
    method createInterpolationTable {mwin font text} {
        set max [winfo vrootwidth $mwin]
        set oldsize [font configure $font -size]
        set xval [list]
        set yval [list]
        set x 0
        set size 2
        while {$x < $max} {
            font configure $font -size $size
            set x [font measure $font $text]
            lappend xval $x
            lappend yval $size
            incr size 4
        }
        font configure $font -size $oldsize
        return [list $xval $yval]
    }

    method adjustFont {font width ipt} {
        set newSize [lindex [math::interpolate::neville [lindex $ipt 0] [lindex $ipt 1] $width] 0]
        font configure $font -size [expr {int($newSize)-2}] ; #added -2 to make it slightly smaller
    }
    
    method configureBinding {ipt mwin width heigth} {
        set font [$self cget -font]
        bind $mwin <Configure> {}
        $self adjustFont $font $width $ipt
        after idle [list bind $mwin <Configure> [mymethod configureBinding $ipt %W %w %h]]
    }
}

# demo
proc demo {} {
  font create title -family Verdana -size 10
  toplevel .test
  set txt " Some Title "
  dlabel .test.l -text $txt -font title
  pack  .test.l -expand 1 -fill both
  wm geometry .test 400x300+0+0
}

DDG - 2020-02-01: Here comes a simpler solution based on font metrics and font measure commands which does not require the math::interpolate package.

package require snit
snit::widget  dlabel2 {
    component label
    option -text "Default"
    delegate method * to label
    delegate option * to label
    option -font ""
    constructor {args} {
        install label using ttk::label $win.lbl {*}$args
        $self configurelist $args
        if {$options(-font) eq ""} {
            set mfont [font create {*}[font configure TkDefaultFont]]
            $label configure -font $mfont
            set options(-font) $mfont
        }
        pack $label -side top -fill both -expand yes -padx 10 -pady 10
        bind  $label <Configure> [mymethod configureBinding %W %w %h] 
    }
    method adjustFont {width height} {
        set cw [font measure $options(-font) $options(-text)]
        set ch [font metrics $options(-font)]
        set size [font configure $options(-font) -size]
        # shrink
        set shrink false
        while {true} {
            set cw [font measure $options(-font) $options(-text)]
            set ch [font metrics $options(-font)]
            set size [font configure $options(-font) -size]

            if {$cw < $width && $ch < $height} {
                break
            }
            incr size -2
            font configure $options(-font) -size $size
            set shrink true
        }
        # grow
        while {!$shrink} {
            set cw [font measure $options(-font) $options(-text)]
            set ch [font metrics $options(-font)]
            set size [font configure $options(-font) -size]
            if {$cw > $width || $ch > $height} {
                incr size -2 ;#set back
                font configure $options(-font) -size $size
                break
            }
            incr size 2
            font configure $options(-font) -size $size
        }
    }
    
    method configureBinding {mwin width height} {
        bind $mwin <Configure> {}
        $self adjustFont $width $height
        after idle [list bind $mwin <Configure> [mymethod configureBinding %W %w %h]]
    }
}
proc demo2 {} {
    # just testing
    font create title -family Verdana -size 10
    toplevel .test
    set txt " Some Title "
    dlabel2 .test.l -text $txt -font title
    pack  .test.l -expand 1 -fill both
    wm geometry .test 400x300+0+0
}