7GUIs is an interesting project to analyse the usability of different GUI toolkits. The 7 mini-application examples give focussed examples of important GUI patterns, such that the implementation should serve as a guide to how the language and toolkit under use help or hinder the programmer.
I expect some interesting Tk implementations to appear, perhaps leading to some discussions of where Tk is not so strong and how it could be improved.
Please add your implementations to this page, or critique ones already here. Adding a single solution (instead of all 7) is welcome, particularly if it highlights a beautiful technique. While showing off 3rd-party libraries is encouraged, at least one "naive Tk" implementation of each example should exist. Though for Cells I fully endorse the use of tablelist, purely on the assumption that no Tk programmer should be without it!
These are intended to highlight how to use core Tcl/Tk features without relying on 3rd-party libraries. The code should be self-contained, though relying on bundled extensions such as ttk, sqlite3 is not discouraged and tcllib / tklib dependencies are not out of the question.
Enough "good practice" should be present to make the examples easy to extend or incorporate into a larger program without butchery. Thus doing everything inside a namespace, despite the extra verbosity of namespace which.
#!/usr/bin/env tclsh
package require Tk
package require lambda
namespace eval app {
variable c 0
entry .e -state readonly -textvariable [namespace which -variable c]
button .b -text Count -command [lambda@ [namespace current] {} {
variable c
incr c
}]
pack .e .b -side left
wm title . Counter
}
wm protocol . WM_DELETE_WINDOW exit
vwait forever#!/usr/bin/env tclsh
package require Tk
package require lambda
namespace eval app {
variable c 0
variable f 32
proc c2f {} {
puts c2f
variable c
variable f
set f [format %.1f [expr {$c * 9 / 5.0 + 32}]]
}
proc f2c {} {
puts f2c
variable f
variable c
set c [format %.1f [expr {($f - 32) * 5 / 9.0}]]
}
entry .c -textvariable [namespace which -variable c]
entry .f -textvariable [namespace which -variable f]
label .cl -text "\u00b0 Celcius"
label .fl -text "\u00b0 Fahrenheit"
trace add variable c write [lambda@ [namespace current] args c2f]
trace add variable f write [lambda@ [namespace current] args f2c]
pack .c .cl .f .fl -side left
}
wm title . "Temperature Converter"
wm protocol . WM_DELETE_WINDOW exit
vwait foreverThis is an example of dependent widgets (whose readonly status is a function of other widgets' values), which is fun with an approach like WJD's dynaforms (paper here ), but a little cumbersome in ordinary Tk (imo). Example Coming Soon.
Solutions #1 and #2 above are already beginning to show that namespace management easily become distracting. TclOO helps a lot:
#!/usr/bin/env tclsh
package require Tk
package require lambda
oo::class create Timer {
variable percent 0
variable started [clock milliseconds]
variable seconds 0s
variable duration 10.0
constructor {} {
set duration 10.0
label .pl -text "Elapsed Time:"
ttk::progressbar .p -variable [my varname percent] -orient h
label .l -textvariable [my varname seconds]
label .sl -text "Duration:"
scale .s -variable [my varname duration] -orient h -from 0.0 -to 15.0 -resolution 0.1
button .r -text "Reset" -command [namespace code {my reset}]
grid .pl .p -sticky nsew
grid .l - -sticky nsew
grid .sl .s -sticky nsew
grid .r - -sticky nsew
grid columnconfigure . 1 -weight 1
wm title . Timer
my reset
after idle [namespace code {my tick}]
}
method reset {} {
set started [clock milliseconds]
}
method tick {} {
set now [clock milliseconds]
set elapsed [expr {($now - $started) / 100 / 10.0}]
set percent [expr {$elapsed * 100 / $duration}]
if {$percent <= 100} {
set seconds [format %.1fs $elapsed]
} else {
set started [expr {$now - int($duration * 1000)}]
}
after idle [namespace code {my tick}]
}
}
Timer create t
wm protocol . WM_DELETE_WINDOW exit
vwait foreverPretty sure we've all written more than plenty of these, but a concise, readable example using modern features will be fun.
This is a nice little demo of canvas, but also calls for some helper code. The most interesting part is an undo facility.
The code below is very rough, but it demonstrates some patterns that really ought to be factored out for reuse .. unless anyone has something better pre-rolled? ;-)
The verbosity of this implementation suggests that it's showing some gaps where Tk could help some more. Still, 200 lines isn't terrible.
#!/usr/bin/env tclsh
package require Tk
package require lambda
# wraps a script in a lambda that ignores all its arguments
# useful for making traces
proc ignoreargs {script} {
lambda@ [uplevel 1 {self namespace}] args $script
}
# list-based stack
interp alias {} lpush {} lappend
proc lpop {_ls varName args} {
upvar 1 $_ls ls
set vals [lrange $ls end-[llength $args] end]
set ls [lreplace $ls end-[llength $args] end]
tailcall ::foreach [list $varName {*}$args] $vals {}
}
# [incr] that doesn't choke on floats
proc incf {varName {expr 1}} {
set varName [list $varName]
tailcall if "\[info exists $varName\]" "
set $varName \[expr {\${$varName} + $expr}\]
" "else" "
set $varName \[expr {$expr}\]
"
}
# dialog box which handles resizing
oo::class create Resizer {
variable w
variable radius
variable id
variable obj
variable undo
constructor {W Obj Id} {
set w $W
set obj $Obj
set id $Id
lassign [$obj get_center $id] x y
set radius [$obj get_radius $id]
set undo [list resize_circle $id $radius]
label $w.l -text "Adjust diameter of circle at ($x, $y)"
scale $w.s -variable [my varname radius] -orient h -from 10.0 -to 500.0 -resolution 1.0
button $w.b -text "Done" -command [namespace code {my Done}]
button $w.c -text "Cancel" -command [namespace code {my Cancel}]
grid $w.l - -sticky nsew
grid $w.s - -sticky nsew
grid $w.b $w.c -sticky nsew
trace add variable [my varname radius] write [ignoreargs {my Changed}]
}
method Changed {} {
puts "Resizing $id to $radius"
$obj resize_circle $id $radius
}
method Cancel {} {
$obj {*}$undo
destroy $w
after idle [list [self] destroy]
}
method Done {} {
$obj push_undo $undo
destroy $w
after idle [list [self] destroy]
}
}
proc resize_circle {obj id} {
set w .resize_${id}
if {[winfo exists $w]} {
raise $w
focus $w
return
}
toplevel $w
Resizer new $w $obj $id
}
oo::class create Circles {
constructor {} {
canvas .c -width 480 -height 320 -background white
button .u -text "Undo" -command [namespace code {my undo}]
button .r -text "Redo" -command [namespace code {my redo}]
grid .c - -sticky nsew
grid .u .r -sticky nsew
grid columnconfigure . 0 -weight 1
grid columnconfigure . 1 -weight 1
grid rowconfigure . 0 -weight 1
bind .c <Configure> [namespace code {my canvas.configure %w %h}]
bind .c <Button-1> [namespace code {my canvas.b1 %x %y}]
bind .c <Button-3> [namespace code {my canvas.b3 %x %y}]
oo::objdefine [self] forward canvas .c
}
# event handlers
method canvas.configure {w h} {
# .c scale all 0 0 [expr {1.0/$w}] [expr {1.0/$h}]
}
method canvas.b1 {x y} {
set item [.c find withtag current]
if {$item ne ""} {
# do nothing
} else {
my do add_circle $x $y
}
}
method canvas.b3 args {
set item [.c find withtag current]
if {$item ne ""} {
resize_circle [self] $item
}
}
# undo helpers
variable undo_stack
variable redo_stack
method do {cmd args} {
lpush undo_stack [my $cmd {*}$args]
}
method push_undo {cmd args} {
lpush undo_stack $cmd {*}$args
}
method undo {} {
if {$undo_stack eq ""} {return}
lpop undo_stack cmd
puts "undo: $cmd"
lpush redo_stack [my {*}$cmd]
}
method redo {} {
if {$redo_stack eq ""} {return}
lpop redo_stack cmd
puts "redo: $cmd"
lpush undo_stack [my {*}$cmd]
}
# circle geometry helpers
method get_center {item} {
foreach {x0 y0} [.c coords $item] {
incf x $x0
incf y $y0
incr n
}
set x [expr {$x / $n}]
set y [expr {$y / $n}]
list $x $y
}
method get_radius {item} {
lassign [.c coords $item] x0 y0 x1 y1
expr {( ($x1 - $x0) + ($y1 - $y0) ) / 4}
}
# actions: each of these returns an undo action
method add_circle {x y {r 50} args} {
set x0 [expr {$x-$r}]
set x1 [expr {$x+$r}]
set y0 [expr {$y-$r}]
set y1 [expr {$y+$r}]
set id [.c create oval $x0 $y0 $x1 $y1 -fill white {*}$args -activefill grey]
return [list delete_circle $id]
}
method delete_circle {id} {
foreach {x y} [my get_center $id] {}
set r [my get_radius $id]
set cfg [lmap ci [.c itemconfigure $id] {
if {[lindex $ci 4] eq [lindex $ci 3]} {
# catches defaults and synonyms
continue
}
list [lindex $ci 0] [lindex $ci 4]
}]
.c delete $id
return [concat add_circle $x $y $r {*}$cfg]
}
method resize_circle {id radius} {
foreach {x y} [my get_center $id] {}
set oldr [my get_radius $id]
set x0 [expr {$x - $radius}]
set x1 [expr {$x + $radius}]
set y0 [expr {$y - $radius}]
set y1 [expr {$y + $radius}]
.c coords $id $x0 $y0 $x1 $y1
return "resize_circle $id $oldr"
}
}
Circles create c
wm protocol . WM_DELETE_WINDOW exit
There are examples like A little spreadsheet and tiny spreadsheet all over the wiki, which could probably do with modernisation ... this is a good example for Tablelist or Tktable to shine.