Engraved Text With Tk

[Sun Home | Tcl Plugin | Demos]

The Tclet below demonstrates some of Tk's capabilities in dealing with structured graphics. Each text line is an item, and it responds differently to mouse actions. Try entering each text item with the mouse, and try dragging it with the left mouse button pressed.

Source

Here is the source (all 120 lines) of this Tclet:

pack [canvas .c -width 500 -height 400 -background grey75]

set font {-*-times-bold-r-normal-*-40-400-*-*-*-*-*-*}

proc raised {c text tc rc font x y n tag} {
  set x1 [expr $x + 1]
  set y1 [expr $y + 1]
  set x0 [expr $x - 1]
  set y0 [expr $y - 1]
  
#  $c create text $x1 $y1 -text $text -font $font \
#    -anchor center -fill grey40 -tags [list bottom $tag]
  for {set i 0} {$i < $n} {incr i} {
     $c create text $x1 $y1 -text $text -font $font \
	-anchor center -fill $rc -tags [list bottom $tag]
     incr x1
     incr y1
  }
  $c create text $x0 $y0 -text $text -font $font \
    -anchor center -fill white -tags [list top $tag]
  $c create text $x $y -text $text -font $font \
    -anchor center -fill $tc -tags [list text $tag]
}

proc sunken {c text tc sc font x y n tag} {
  set x1 [expr $x + 1]
  set y1 [expr $y + 1]
  set x0 [expr $x - 1]
  set y0 [expr $y - 1]
  
  for {set i 0} {$i < $n} {incr i} {
    $c create text $x1 $y1 -text $text -font $font \
      -anchor center -fill $sc -tags [list bottom $tag]
    incr x1
    incr y1
  }
  $c create text $x0 $y0 -text $text -font $font \
    -anchor center -fill grey30 -tags [list top $tag]
  $c create text $x $y -text $text -font $font \
    -anchor center -fill grey90 -tags [list bottom $tag]
}

proc impressed {c text tc font x y tag} {
  set x1 [expr $x + 1]
  set y1 [expr $y + 1]
  set x0 [expr $x - 1]
  set y0 [expr $y - 1]
  
  $c create text $x1 $y1 -text $text -font $font \
    -anchor center -fill white -tags [list bottom $tag]
  $c create text $x0 $y0 -text $text -font $font \
    -anchor center -fill black -tags [list top $tag]
  $c create text $x $y -text $text -font $font \
    -anchor center -fill $tc -tags [list text $tag]
}

proc shadowed {c text tc sc font x y off tag} {
  set x2 [expr $x + $off]
  set y2 [expr $y + $off]
  $c create text $x2 $y2 -text $text -font $font \
    -anchor center -fill $sc -tags [list top $tag]
  $c create text $x $y -text $text -font $font \
    -anchor center -fill $tc -tags [list text $tag]
}
proc startdrag {x y} {
    global startx starty
    set startx $x
    set starty $y
}
proc movedrag {w x y tag} {
    global startx starty
    set dx [expr $x - $startx]
    set dy [expr $y - $starty]
    $w move $tag $dx $dy
    set startx $x
    set starty $y
}
proc raising {c text tc sc font x y tag} {
  set x2 [expr $x + 1]
  set y2 [expr $y + 1]
  $c create text $x2 $y2 -text $text -font $font \
    -anchor center -fill $sc -tags [list top $tag ${tag}shadow]
  $c create text $x $y -text $text -font $font \
    -anchor center -fill $tc -tags [list text $tag ${tag}front]
}
proc raise {c count limit tag} {
   if {$count > $limit} {
      return
   }
   incr count
   set grey grey[expr $count * 7]
   $c itemconfigure ${tag}shadow -fill $grey
   $c move ${tag}front -1 -1
   after 100 raise $c $count $limit $tag
}
proc lower {c count limit tag} {
   if {$count > $limit} {
     $c itemconfigure ${tag}shadow -fill black
     return
   }
   incr count
   set grey grey[expr (10 - $count) * 7]
   $c itemconfigure ${tag}shadow -fill $grey
   $c move ${tag}front 1 1
   after 100 lower $c $count $limit $tag
}
proc fading {c text tc font x y tag} {
  $c create text $x $y -text $text -font $font \
    -anchor center -fill $tc -tags [list top $tag]
}
proc fade {c tag cur limit} {
  if {$cur > $limit} {
    $c itemconfigure $tag -fill grey$limit
    return
  }
  $c itemconfigure $tag -fill grey$cur
  incr cur 4
  after 100 fade $c $tag $cur $limit
}
proc unfade {c tag cur} {
  if {$cur < 0} {
    return
  }
  $c itemconfigure $tag -fill grey$cur
  incr cur -4
  after 100 unfade $c $tag $cur
}

raised .c "Raised text" green gray40 $font 250 50 8 raised
sunken .c "Sunken text" grey80 grey70 $font 250 150 3 sunken
shadowed .c "Shadowed, floating text." white grey40 $font 250 250 10 shadowed
impressed .c "Impressed text." black $font 150 100 impressed
fading .c "Mouse sensitive text" black $font 250 300 fading
raising .c "Mouse sensitive text" white grey40 $font 250 350 raising

.c bind raised <Button-1> "startdrag %x %y"
.c bind raised <B1-Motion> "movedrag %W %x %y raised"

.c bind sunken <Button-1> "startdrag %x %y"
.c bind sunken <B1-Motion> "movedrag %W %x %y sunken"

.c bind shadowed <Button-1> "startdrag %x %y"
.c bind shadowed <B1-Motion> "movedrag %W %x %y shadowed"

.c bind impressed <Button-1> "startdrag %x %y"
.c bind impressed <B1-Motion> "movedrag %W %x %y impressed"

.c bind raising <Enter> "raise .c 0 8 raising"
.c bind raising <Leave> "lower .c 0 8 raising"

.c bind raising <Button-1> "startdrag %x %y"
.c bind raising <B1-Motion> "movedrag %W %x %y raising"

.c bind fading <Enter> "fade .c fading 0 75"
.c bind fading <Leave> "unfade .c fading 75"

.c bind fading <Button-1> "startdrag %x %y"
.c bind fading <B1-Motion> "movedrag %W %x %y fading"