Version 5 of Smalltick Widgets with Inheritance
Updated 2004-05-21 06:05:38 by GPSUPDATED May 20, 2004
GPS: This page serves to demonstrate the design behind the Smalltick Tk widgets.
For years I've thought about widgets with inheritance for Tcl/Tk. A couple of weeks ago the ideas hit me, and I realized I might be able to bring these ideas to fruition.
3 Smalltick Button widgets that have inherited from the Widget, Container, and Button classes: 
This time demonstrating a color change and the method set.border.relief: 
The relevent code from the top down to produce the images above is:
proc main {} {
set mw [Widget [new.object]]
$mw set {window-path .}
set b [Button [new.object] $mw]
$b -column 0 -row 0 -sticky news -map
$b -text [list "Hello World"]
set bell [Button [new.object] $mw]
$bell \
-text [list "Press me to make some noise!"] \
-command [list {puts "\a\a"}]
$bell -column 1 -row 1 -sticky news -map
set col [Button [new.object] $mw]
$col \
-text [list "Press me to select a color."] \
-command [list {$self -bg [tk_chooseColor]}]
$col -column 0 -row 2 -sticky news -map
}GPS: When I discussed my project in the Tcl'ers Chat DKF and others were critical of the idea of using inheritance with widgets. I've found it hasn't been a problem.
Here is the entire Button class:
proc Button {b p} {
Container $b $p
$b set {button-text ""}
$b set [list button-font [gui.create.font "Helvetica 14"]]
$b set [list button-gc [gui.create.gc [$b get wid]]]
$b set {button-text ""}
$b set {button-draw-is-pending 0}
$b set {command ""}
$b : -command c {
$self ?set [list command $c]
}
$b : -text t {
$self ?set [list button-text $t]
$self calculate.button.text.size
gui.request.geometry \
[$self get window-path] \
[expr {[$self get button-text-width] + 6}] \
[expr {[$self get button-text-height] + 4}]
$self draw.button.when.idle
}
$b : button.press.event {} {
$self set.border.relief pressed
$self draw.button.when.idle
}
$b : button.release.event {x y} {
$self set.border.relief normal
$self draw.button.when.idle
eval [$self get command]
}
$b : calculate.button.text.size {} {
$self set [list button-text-height \
[lindex [gui.get.font.metrics [$self get button-font]] end]]
$self set [list button-text-width \
[gui.measure.string [$self get button-font] [$self get button-text]]]
}
$b : draw.button {} {
gui.draw.text \
[$self get wid] \
[$self get button-gc] \
[$self get button-font] \
3 \
[$self get button-text-height] \
[$self get button-text]
$self set {button-draw-is-pending 0}
}
$b : draw.button.when.idle {} {
if {[$self get button-draw-is-pending]} return
$self set {button-draw-is-pending 1}
after idle [list $self draw.button]
}
bind Button$b <Expose> [list $b draw.button.when.idle]
bind Button$b <Configure> [list $b draw.button.when.idle]
bind Button$b <ButtonPress-1> [list $b button.press.event]
bind Button$b <ButtonRelease-1> [list $b button.release.event {%x %y}]
bindtags [$b get window-path] [linsert [bindtags [$b get window-path]] end Button$b]
$b calculate.button.text.size
$b draw.button.when.idle
return $b
}I've made some changes to the Container class and now it looks like this (in 2.6):
proc Container {c p} {
Widget $c
$c set [list window-path \
[set w [gui.get.unique.window.path [$p get window-path]]]]
set wid [gui.get.window.id [gui.create.window $w]]
$c set [list wid $wid]
#These 3 sets of commands are very alike.
#I can't think of the best way to factor them yet.
$c set [list bg-gc [gui.create.gc $wid]]
$c set [list bg-color [gui.create.color gray70]]
gui.set.gc.color [$c get bg-gc] [$c get bg-color]
$c set [list bd-light-gc [gui.create.gc $wid]]
$c set [list bd-light-color [gui.create.color gray90]]
gui.set.gc.color [$c get bd-light-gc] [$c get bd-light-color]
$c set [list bd-dark-gc [gui.create.gc $wid]]
$c set [list bd-dark-color [gui.create.color gray30]]
gui.set.gc.color [$c get bd-dark-gc] [$c get bd-dark-color]
$c set [list copy-gc [gui.create.gc $wid]]
$c set {container-draw-is-pending 0}
$c set {container-pixmap-width 0}
$c set {container-pixmap-height 0}
$c set {container-pixmap 0}
$c set {request-width 100}
$c set {request-height 100}
$c : -bg color {
gui.destroy.color [$self get bg-color]
$self set [list bg-color [gui.create.color $color]]
gui.set.gc.color [$self get bg-gc] [$self get bg-color]
$self draw.container.when.idle
}
$c : -height h {
$self set [list request-height $h]
$self request.geometry
}
$c : -width w {
$self set [list request-width $w]
$self request.geometry
}
$c : build.container.pixmap.if.needed {w h} {
if {[$self get container-pixmap-width] == $w \
&& [$self get container-pixmap-height] == $h} {
return 0
}
if {0 != [$self get container-pixmap]} {
gui.destroy.pixmap [$self get container-pixmap]
}
$self set [list container-pixmap \
[gui.create.pixmap [$self get window-path] $w $h]]
return 1
}
$c : copy.container.pixmap.to.window {w h} {
gui.copy.area \
[$self get copy-gc] \
[$self get container-pixmap] \
[$self get wid] \
0 0 $w $h 0 0
}
$c : draw.container {} {
set w [winfo width [$self get window-path]]
set h [winfo height [$self get window-path]]
if {![$self build.container.pixmap.if.needed [list $w $h]]} {
$self copy.container.pixmap.to.window [list $w $h]
}
gui.draw.rectangle \
[$self get container-pixmap] \
[$self get bg-gc] \
0 0 \
[winfo width [$self get window-path]] \
[winfo height [$self get window-path]]
$self draw.container.border [list [$self get container-pixmap] $w $h]
$self set {container-draw-is-pending 0}
$self copy.container.pixmap.to.window [list $w $h]
}
$c : draw.container.border {pix w h} {
gui.draw.line \
$pix \
[$self get bd-light-gc] \
0 0 0 $h
gui.draw.line \
$pix \
[$self get bd-light-gc] \
0 0 $w 0
gui.draw.line \
$pix \
[$self get bd-dark-gc] \
[expr {$w - 1}] 0 [expr {$w - 1}] $h
gui.draw.line \
$pix \
[$self get bd-dark-gc] \
0 [expr {$h - 1}] $w [expr {$h - 1}]
}
$c : draw.container.when.idle {} {
if {[$self get container-draw-is-pending]} return
$self set {container-draw-is-pending 1}
after idle [list $self draw.container]
}
$c : request.geometry {} {
gui.request.geometry \
[$self get window-path] \
[$self get request-width] \
[$self get request-height]
}
$c : set.border.relief type {
if {"pressed" eq $type} {
gui.set.gc.color [$self get bd-light-gc] [$self get bd-dark-color]
gui.set.gc.color [$self get bd-dark-gc] [$self get bd-light-color]
} else {
gui.set.gc.color [$self get bd-light-gc] [$self get bd-light-color]
gui.set.gc.color [$self get bd-dark-gc] [$self get bd-dark-color]
}
$self draw.container.when.idle
}
bind Container$w <Configure> [list $c draw.container.when.idle]
bind Container$w <Expose> [list $c draw.container.when.idle]
bindtags $w [list $w Container$w all]
$c request.geometry
$c draw.container
return $c
}You may wonder: why is this cool? To me it's cool because the widgets are mostly written in Tcl. The various gui.* commands you see used above are provided by a simple C extension I wrote. That said, there is work left to do. The code above is unfinished, because it doesn't provide cleanup for memory allocated, but I felt it was interesting to share the ideas behind this on the Wiki so that people in the chat might discuss it.