[ulis], 2003-09-17
----
[http://perso.wanadoo.fr/maurice.ulis/tcl/flowers.gif]
----
Please download the images files in the current directory before executing the script:
  http://perso.wanadoo.fr/maurice.ulis/tcl/flower-1.gif
  http://perso.wanadoo.fr/maurice.ulis/tcl/flower-2.gif
  http://perso.wanadoo.fr/maurice.ulis/tcl/flower-3.gif
----
  # -------------
  # create images
  # -------------

  foreach image {flower1 flower2 flower3} \
          file  {flower-1.gif flower-2.gif flower-3.gif} \
  {
    image create photo $image -file $file
  }

  # -------------
  # bimage
  # -------------

  proc nmage {w args} \
  {
    set image [lindex $args 0]
    set ww [image width $image]
    set hh [image height $image]
    set x [expr {$ww / 2}]
    set y [expr {$hh / 2}]
    canvas $w -width $ww -height $hh -highlightt 0
    set n 0
    foreach image $args \
    {
      $w create image $x $y -anchor center \
        -image $image -tags _[incr n]
    }
  }
  proc bimage {num flower image1 image2 {color ""}} \
  {
    set ww [image width $flower]
    set hh [image height $flower]
    set miniw [expr {$ww / 4}]
    set minih [expr {$hh / 4}]
    image create photo mini$num -width $miniw -height $minih
    mini$num copy flower$num -subsample 4
    set microw [expr {$ww / 8}]
    set microh [expr {$hh / 8}]
    image create photo micro$num -width $microw -height $microh
    micro$num copy flower$num -subsample 8
    nmage .$num $image1 $image2
    set ::info(.$num) [list $flower $color]
  }
  proc select {w n {max 2}} \
  {
    for {set i 1} {$i <= $max} {incr i} \
    {
      if {$i == $n} { $w itemconf _$i -state normal } \
      else { $w itemconf _$i -state hidden }
    }
  }
  
  # -------------
  # create widgets
  # -------------

  nmage .0 flower1 flower2 flower3
  label .name -font {Times -24}
  bimage 1 flower1 mini1 micro1 DeepPink3
  bind .1 <1> {change 1}
  bimage 2 flower2 mini2 micro2 orange
  bind .2 <1> {change 2}
  bimage 3 flower3 mini3 micro3 blue
  bind .3 <1> {change 3}

  # -------------
  # place & display widgets
  # -------------

  grid .1    -row 2 -column 0 -padx 10 -sticky e
  grid .2    -row 2 -column 1 -padx 10
  grid .3    -row 2 -column 2 -padx 10 -sticky w
  grid .0    -row 0 -columnspan 3 
  grid .name -row 1 -columnspan 3

  # -------------
  # mechanism
  # -------------

  proc change {num} \
  {
    foreach {name color} $::info(.$num) break
    select .0 $num 3
    .name config -text $name
    foreach w {. .name .0 .1 .2 .3} { $w config -bg $color }
    foreach w {.1 .2 .3} { select $w [expr {$w == ".$num" ? 1 : 2}] }
  }

  # -------------
  # do it!
  # -------------

  wm title . flowers
  change 1
----
[Category Example]