Tcl Programming/Tk examples
The following examples originally appeared in the Tcler's Wiki http://wiki.tcl.tk . They are all in the public domain - no rights reserved.
A funny cookbook
editThis funny little program produces random cooking recipes. Small as it is, it can produce 900 different recipes, though they might not be to everybody's taste... The basic idea is to pick an arbitrary element from a list, which is easily done in Tcl with the following:
proc ? L {lindex $L [expr {int(rand()*[llength $L])}]}
This is used several times in:
proc recipe {} {
set a {
{3 eggs} {an apple} {a pound of garlic}
{a pumpkin} {20 marshmallows}
}
set b {
{Cut in small pieces} {Dissolve in lemonade}
{Bury in the ground for 3 months}
{Bake at 300 degrees} {Cook until tender}
}
set c {parsley snow nutmeg curry raisins cinnamon}
set d {
ice-cream {chocolate cake} spinach {fried potatoes} rice {soy sprouts}
}
return " Take [? $a].
[? $b].
Top with [? $c].
Serve with [? $d]."
}
And as modern programs always need a GUI, here is a minimal one that appears when you source this file at top level, and shows a new recipe every time you click on it:
if {[file tail [info script]]==[file tail $argv0]} {
package require Tk
pack [text .t -width 40 -height 5]
bind .t <1> {showRecipe %W; break}
proc showRecipe w {
$w delete 1.0 end
$w insert end [recipe]
}
showRecipe .t
}
Enjoy!
A little A/D clock
editThis is a clock that shows time either analog or digital - just click on it to toggle.
#!/usr/bin/env tclsh
package require Tk
proc every {ms body} {eval $body; after $ms [info level 0]}
proc drawhands w {
$w delete hands
set secSinceMidnight [expr {[clock sec]-[clock scan 00:00:00]}]
foreach divisor {60 3600 43200} length {45 40 30} width {1 3 7} {
set angle [expr {$secSinceMidnight * 6.283185 / $divisor}]
set x [expr {50 + $length * sin($angle)}]
set y [expr {50 - $length * cos($angle)}]
$w create line 50 50 $x $y -width $width -tags hands
}
}
proc toggle {w1 w2} {
if [winfo ismapped $w2] {
foreach {w2 w1} [list $w1 $w2] break ;# swap
}
pack forget $w1
pack $w2
}
#-- Creating the analog clock:
canvas .analog -width 100 -height 100 -bg white
every 1000 {drawhands .analog}
pack .analog
#-- Creating the digital clock:
label .digital -textvar ::time -font {Courier 24}
every 1000 {set ::time [clock format [clock sec] -format %H:%M:%S]}
bind . <1> {toggle .analog .digital}
A little pie chart
edit
Arc elements of a canvas are by default rendered as pie slices (part of the circumference of a circle, connected by radius lines to the center. Hence it s rather easy to produce a pie chart. The following code is a bit more complex, as it also determines positions for the labels of the pies:
proc piechart {w x y width height data} {
set coords [list $x $y [expr {$x+$width}] [expr {$y+$height}]]
set xm [expr {$x+$width/2.}]
set ym [expr {$y+$height/2.}]
set rad [expr {$width/2.+20}]
set sum 0
foreach item $data {set sum [expr {$sum + [lindex $item 1]}]}
set start 270
foreach item $data {
foreach {name n color} $item break
set extent [expr {$n*360./$sum}]
$w create arc $coords -start $start -extent $extent -fill $color
set angle [expr {($start-90+$extent/2)/180.*acos(-1)}]
set tx [expr $xm-$rad*sin($angle)]
set ty [expr $ym-$rad*cos($angle)]
$w create text $tx $ty -text $name:$n -tag txt
set start [expr $start+$extent]
}
$w raise txt
}
Testing:
pack [canvas .c -bg white]
piechart .c 50 50 150 150 {
{SPD 199 red}
{CDU 178 gray}
{CSU 23 blue}
{FDP 60 yellow}
{Grüne 58 green}
{Linke 55 purple}
}
A little 3D bar chart
edit
The following script displays a bar chart on a canvas, with pseudo-3-dimensional bars - a rectangle in front as specified, embellished with two polygons - one for the top, one for the side:}
proc 3drect {w args} {
if [string is int -strict [lindex $args 1]] {
set coords [lrange $args 0 3]
} else {
set coords [lindex $args 0]
}
foreach {x0 y0 x1 y1} $coords break
set d [expr {($x1-$x0)/3}]
set x2 [expr {$x0+$d+1}]
set x3 [expr {$x1+$d}]
set y2 [expr {$y0-$d+1}]
set y3 [expr {$y1-$d-1}]
set id [eval [list $w create rect] $args]
set fill [$w itemcget $id -fill]
set tag [$w gettags $id]
$w create poly $x0 $y0 $x2 $y2 $x3 $y2 $x1 $y0 \
-fill [dim $fill 0.8] -outline black
$w create poly $x1 $y1 $x3 $y3 $x3 $y2 $x1 $y0 \
-fill [dim $fill 0.6] -outline black -tag $tag
}
For a more plastic look, the fill color of the polygons is reduced in brightness ("dimmed"):
proc dim {color factor} {
foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
set $i [expr int(255.*$n/$d*$factor)]
}
format #%02x%02x%02x $r $g $b
}
Draw a simple scale for the y axis, and return the scaling factor:
proc yscale {w x0 y0 y1 min max} {
set dy [expr {$y1-$y0}]
regexp {([1-9]+)} $max -> prefix
set stepy [expr {1.*$dy/$prefix}]
set step [expr {$max/$prefix}]
set y $y0
set label $max
while {$label>=$min} {
$w create text $x0 $y -text $label -anchor w
set y [expr {$y+$stepy}]
set label [expr {$label-$step}]
}
expr {$dy/double($max)}
}
An interesting sub-challenge was to round numbers very roughly, to 1 or maximally 2 significant digits - by default rounding up, add "-" to round down:
proc roughly {n {sgn +}} {
regexp {(.+)e([+-])0*(.+)} [format %e $n] -> mant sign exp
set exp [expr $sign$exp]
if {abs($mant)<1.5} {
set mant [expr $mant*10]
incr exp -1
}
set t [expr round($mant $sgn 0.49)*pow(10,$exp)]
expr {$exp>=0? int($t): $t}
}
So here is my little bar chart generator. Given a canvas pathname, a bounding rectangle, and the data to display (a list of {name value color} triples), it figures out the geometry. A gray "ground plane" is drawn first. Note how negative values are tagged with "d"(eficit), so they look like they "drop through the plane".
proc bars {w x0 y0 x1 y1 data} {
set vals 0
foreach bar $data {
lappend vals [lindex $bar 1]
}
set top [roughly [max $vals]]
set bot [roughly [min $vals] -]
set f [yscale $w $x0 $y0 $y1 $bot $top]
set x [expr $x0+30]
set dx [expr ($x1-$x0-$x)/[llength $data]]
set y3 [expr $y1-20]
set y4 [expr $y1+10]
$w create poly $x0 $y4 [expr $x0+30] $y3 $x1 $y3 [expr $x1-20] $y4 -fill gray65
set dxw [expr $dx*6/10]
foreach bar $data {
foreach {txt val col} $bar break
set y [expr {round($y1-($val*$f))}]
set y1a $y1
if {$y>$y1a} {swap y y1a}
set tag [expr {$val<0? "d": ""}]
3drect $w $x $y [expr $x+$dxw] $y1a -fill $col -tag $tag
$w create text [expr {$x+12}] [expr {$y-12}] -text $val
$w create text [expr {$x+12}] [expr {$y1a+2}] -text $txt -anchor n
incr x $dx
}
$w lower d
}
Generally useful helper functions:
proc max list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {
if {$e>$res} {set res $e}
}
set res
}
proc min list {
set res [lindex $list 0]
foreach e [lrange $list 1 end] {
if {$e<$res} {set res $e}
}
set res
}
proc swap {_a _b} {
upvar 1 $_a a $_b b
foreach {a b} [list $b $a] break
}
Testing the whole thing (see screenshot):
pack [canvas .c -width 240 -height 280]
bars .c 10 20 240 230 {
{red 765 red}
{green 234 green}
{blue 345 blue}
{yel-\nlow 321 yellow}
{ma-\ngenta 567 magenta}
{cyan -123 cyan}
{white 400 white}
}
.c create text 120 10 -anchor nw -font {Helvetica 18} -text "Bar Chart\nDemo"
A little calculator
edit
Here is a small calculator in Tcl/Tk. In addition to the buttons on screen, you can use any of expr's other functionalities via keyboard input.
package require Tk
wm title . Calculator
grid [entry .e -textvar e -just right] -columnspan 5
bind .e <Return> =
set n 0
foreach row {
{7 8 9 + -}
{4 5 6 * /}
{1 2 3 ( )}
{C 0 . = }
} {
foreach key $row {
switch -- $key {
= {set cmd =}
C {set cmd {set clear 1; set e ""}}
default {set cmd "hit $key"}
}
lappend keys [button .[incr n] -text $key -command $cmd]
}
eval grid $keys -sticky we ;#-padx 1 -pady 1
set keys [list]
}
grid .$n -columnspan 2 ;# make last key (=) double wide
proc = {} {
regsub { =.+} $::e "" ::e ;# maybe clear previous result
if [catch {set ::res [expr [string map {/ *1.0/} $::e]]}] {
.e config -fg red
}
append ::e = $::res
.e xview end
set ::clear 1
}
proc hit {key} {
if $::clear {
set ::e ""
if ![regexp {[0-9().]} $key] {set ::e $::res}
.e config -fg black
.e icursor end
set ::clear 0
}
.e insert end $key
}
set clear 0
focus .e ;# allow keyboard input
wm resizable . 0 0
And, as Cameron Laird noted, this thingy is even programmable: enter for example
[proc fac x {expr {$x<2? 1: $x*[fac [incr x -1]]}}]
into the entry, disregard warnings; now you can do
[fac 10]
and receive [fac 10] = 3628800.0 as result...
A little slide rule
editThe slide rule was an analog, mechanical device for approximate engineering computing, made obsolete by the pocket calculator since about the 1970-80s. The basic principle is that multiplication is done by adding logarithms, hence most of the scales are logarithmic, with uneven increments.
This fun project recreates a slide rule (roughly an Aristo-Rietz Nr. 89 with 7 scales - high-notch ones had up to 24) with a white "body" and a beige "slide" which you can move left or right with mouse button 1 clicked, or in pixel increment with the <Shift-Left>/<Shift-Right> cursor keys. Finally, the blue line represents the "mark" (how is that correctly called? "runner"? "slider"?) which you can move with the mouse over the whole thing to read a value. Fine movements with <Left>/<Right>.
Due to rounding errors (integer pixels), this plaything is even less precise than a physical slide rule was, but maybe you still enjoy the memories... The screenshot shows how I found out that 3 times 7 is approx. 21... (check the A and B scales).
proc ui {} {
set width 620
pack [canvas .c -width $width -height 170 -bg white]
pack [label .l -textvariable info -fg blue] -fill x
.c create rect 0 50 $width 120 -fill grey90
.c create rect 0 50 $width 120 -fill beige -outline beige \
-tag {slide slidebase}
.c create line 0 0 0 120 -tag mark -fill blue
drawScale .c K x3 10 5 5 log10 1 1000 186.6666667
drawScale .c A x2 10 50 -5 log10 1 100 280
drawScale .c B x2 10 50 5 log10 1 100 280 slide
drawScale .c CI 1/x 10 90 -5 -log10 1 10 560 slide
drawScale .c C x 10 120 -5 log10 1 10 560 slide
drawScale .c D x 10 120 5 log10 1 10 560
drawScale .c L "lg x" 10 160 -5 by100 0 10 5600
bind .c <Motion> {.c coords mark %x 0 %x 170; set info [values .c]}
bind .c <1> {set x %x}
bind .c <B1-Motion> {%W move slide [expr {%x-$x}] 0; set x %x}
bind . <Shift-Left> {.c move slide -1 0; set info [values .c]}
bind . <Shift-Right> {.c move slide 1 0; set info [values .c]}
bind . <Left> {.c move mark -1 0; set info [values .c]}
bind . <Right> {.c move mark 1 0; set info [values .c]}
}
proc drawScale {w name label x y dy f from to fac {tag {}}} {
set color [expr {[string match -* $f]? "red": "black"}]
$w create text $x [expr $y+2*$dy] -text $name -tag $tag -fill $color
$w create text 600 [expr $y+2*$dy] -text $label -tag $tag -fill $color
set x [expr {[string match -* $f]? 580: $x+10}]
set mod 5
set lastlabel ""
set lastx 0
for {set i [expr {$from*10}]} {$i<=$to*10} {incr i} {
if {$i>100} {
if {$i%10} continue ;# coarser increments
set mod 50
}
if {$i>1000} {
if {$i%100} continue ;# coarser increments
set mod 500
}
set x0 [expr $x+[$f [expr {$i/10.}]]*$fac]
set y1 [expr {$i%(2*$mod)==0? $y+2.*$dy: $i%$mod==0? $y+1.7*$dy: $y+$dy}]
set firstdigit [string index $i 0]
if {$y1==$y+$dy && abs($x0-$lastx)<2} continue
set lastx $x0
if {$i%($mod*2)==0 && $firstdigit != $lastlabel} {
$w create text $x0 [expr $y+3*$dy] -text $firstdigit \
-tag $tag -font {Helvetica 7} -fill $color
set lastlabel $firstdigit
}
$w create line $x0 $y $x0 $y1 -tag $tag -fill $color
}
}
proc values w {
set x0 [lindex [$w coords slidebase] 0]
set x1 [lindex [$w coords mark] 0]
set lgx [expr {($x1-20)/560.}]
set x [expr {pow(10,$lgx)}]
set lgxs [expr {($x1-$x0-20)/560.}]
set xs [expr {pow(10,$lgxs)}]
set res K:[format %.2f [expr {pow($x,3)}]]
append res " A:[format %.2f [expr {pow($x,2)}]]"
append res " B:[format %.2f [expr {pow($xs,2)}]]"
append res " CI:[format %.2f [expr {pow(10,-$lgxs)*10}]]"
append res " C:[format %.2f $xs]"
append res " D:[format %.2f $x]"
append res " L:[format %.2f $lgx]"
}
proc pow10 x {expr {pow(10,$x)}}
proc log10 x {expr {log10($x)}}
proc -log10 x {expr {-log10($x)}}
proc by100 x {expr {$x/100.}}
#--------------------------------
ui
bind . <Escape> {exec wish $argv0 &; exit}
A minimal doodler
editHere is a tiny but complete script that allows doodling (drawing with the mouse) on a canvas widget:
proc doodle {w {color black}} {
bind $w <1> [list doodle'start %W %x %y $color]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
proc doodle'start {w x y color} {
set ::_id [$w create line $x $y $x $y -fill $color]
}
proc doodle'move {w x y} {
$w coords $::_id [concat [$w coords $::_id] $x $y]
}
pack [canvas .c -bg white] -fill both -expand 1
doodle .c
bind .c <Double-3> {%W delete all}
And here it comes again, but this time with explanations:
The "Application Program Interface" (API) for this, if you want such ceremonial language, is the doodle command, where you specify which canvas widget should be enabled to doodle, and in which color (defaults to black):}
proc doodle {w {color black}} {
bind $w <1> [list doodle'start %W %x %y $color]
bind $w <B1-Motion> {doodle'move %W %x %y}
}
It registers two bindings for the canvas, one (<1>) when the left mouse-button is clicked, and the other when the mouse is moved with button 1 (left) down. Both bindings just call one internal function each.
On left-click, a line item is created on the canvas in the specified fill color, but with no extent yet, as start and end points coincide. The item ID (a number assigned by the canvas) is kept in a global variable, as it will have to persist long after this procedure has returned:
proc doodle'start {w x y color} {
set ::_id [$w create line $x $y $x $y -fill $color]
}
The left-motion procedure obtains the coordinates (alternating x and y) of the globally known doodling line object, appends the current coordinates to it, and makes this the new coordinates - in other words, extends the line to the current mouse position:
proc doodle'move {w x y} {
$w coords $::_id [concat [$w coords $::_id] $x $y]
}
That's all we need to implement doodling - now let's create a canvas to test it, and pack it so it can be drawn as big as you wish:
pack [canvas .c -bg white] -fill both -expand 1
And this line turns on the doodle functionality created above (defaulting to black):
doodle .c
Add a binding for double-right-click/double-button-3, to clear the canvas (added by MG, Apr 29 04)
bind .c <Double-3> {%W delete all}
A tiny drawing program
editHere is a tiny drawing program on a canvas. Radio buttons on top allow choice of draw mode and fill color. In "Move" mode, you can of course move items around. Right-click on an item to delete it.
A radio is an obvious "megawidget" to hold a row of radiobuttons. This simple one allows text or color mode: }
proc radio {w var values {col 0}} {
frame $w
set type [expr {$col? "-background" : "-text"}]
foreach value $values {
radiobutton $w.v$value $type $value -variable $var -value $value \
-indicatoron 0
if $col {$w.v$value config -selectcolor $value -borderwidth 3}
}
eval pack [winfo children $w] -side left
set ::$var [lindex $values 0]
set w
}
Depending on draw mode, the mouse events "Down" and "Motion" have different handlers, which are dispatched by names that look like array elements. So for a mode X, we need a pair of procs, down(X) and move(X). Values used between calls are kept in global variables.
First, the handlers for free-hand line drawing:
proc down(Draw) {w x y} {
set ::ID [$w create line $x $y $x $y -fill $::Fill]
}
proc move(Draw) {w x y} {
$w coords $::ID [concat [$w coords $::ID] $x $y]
}
#-- Movement of an item
proc down(Move) {w x y} {
set ::ID [$w find withtag current]
set ::X $x; set ::Y $y
}
proc move(Move) {w x y} {
$w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
set ::X $x; set ::Y $y
}
#-- Clone an existing item
proc serializeCanvasItem {c item} {
set data [concat [$c type $item] [$c coords $item]]
foreach opt [$c itemconfigure $item] {
# Include any configuration that deviates from the default
if {[lindex $opt end] != [lindex $opt end-1]} {
lappend data [lindex $opt 0] [lindex $opt end]
}
}
return $data
}
proc down(Clone) {w x y} {
set current [$w find withtag current]
if {[string length $current] > 0} {
set itemData [serializeCanvasItem $w [$w find withtag current]]
set ::ID [eval $w create $itemData]
set ::X $x; set ::Y $y
}
}
interp alias {} move(Clone) {} move(Move)
#-- Drawing a rectangle
proc down(Rect) {w x y} {
set ::ID [$w create rect $x $y $x $y -fill $::Fill]
}
proc move(Rect) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
#-- Drawing an oval (or circle, if you're careful)
proc down(Oval) {w x y} {
set ::ID [$w create oval $x $y $x $y -fill $::Fill]
}
proc move(Oval) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
Polygons are drawn by clicking the corners. When a corner is close enough to the first one, the polygon is closed and drawn.
proc down(Poly) {w x y} {
if [info exists ::Poly] {
set coords [$w coords $::Poly]
foreach {x0 y0} $coords break
if {hypot($y-$y0,$x-$x0)<10} {
$w delete $::Poly
$w create poly [lrange $coords 2 end] -fill $::Fill
unset ::Poly
} else {
$w coords $::Poly [concat $coords $x $y]
}
} else {
set ::Poly [$w create line $x $y $x $y -fill $::Fill]
}
}
proc move(Poly) {w x y} {#nothing}
#-- With little more coding, the Fill mode allows changing an item's fill color:
proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
proc move(Fill) {w x y} {}
#-- Building the UI
set modes {Draw Move Clone Fill Rect Oval Poly}
set colors {
black white magenta brown red orange yellow green green3 green4
cyan blue blue4 purple
}
grid [radio .1 Mode $modes] [radio .2 Fill $colors 1] -sticky nw
grid [canvas .c -relief raised -borderwidth 1] - -sticky news
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
#-- The current mode is retrieved at runtime from the global Mode variable:
bind .c <1> {down($Mode) %W %x %y}
bind .c <B1-Motion> {move($Mode) %W %x %y}
bind .c <3> {%W delete current}
For saving the current image, you need the Img extension, so just omit the following binding if you don't have Img:
bind . <F1> {
package require Img
set img [image create photo -data .c]
set name [tk_getSaveFile -filetypes {{GIFF .gif} {"All files" *}}\
-defaultextension .gif]
if {$name ne ""} {$img write $name; wm title . $name}
}
#-- This is an always useful helper in development:
bind . <Escape> {exec wish $argv0 &; exit}
A minimal editor
editHere's an utterly simple editor, in 26 lines of code, which just allows to load and save files, and of course edit, and cut and paste, and whatever is built-in into the text widget anyway. And it has a bit "online help"... ;-)
It is always a good idea to start a source file with some explanations on the name, purpose, author, and date. I have recently picked up the habit to put this information into a string variable (which in Tcl can easily span multiple lines), so the same info is presented to the reader of the source code, and can be displayed as online help: }
set about "minEd - a minimal editor Richard Suchenwirth 2003 F1: help F2: load F3: save "
The visible part of a Graphical User Interface (GUI) consists of widgets. For this editor, I of course need a text widget, and a vertical scrollbar. With the option "-wrap word" for the text widget, another horizontal scrollbar is not needed - lines longer than the window just wrap at word boundaries.
Tk widgets come on the screen in two steps: first, they are created with an initial configuration; then, handed to a "geometry manager" for display. As widget creation commands return the pathname, they can be nested into the manager command (pack in this case), to keep all settings for a widget in one place. This may lead to over-long lines, though.
Although the scrollbar comes to the right of the text, I create and pack it first. The reason is that when a window is made smaller by the user, the widgets last packed first lose visibility.
These two lines also illustrate the coupling between a scrollbar and the widget it controls:
- the scrollbar sends a yview message to it when moved
- the widget sends a set message to the scrollbar when the view changed, for instance from cursor keys
And these two lines already give us an editor for arbitrarily long text, with built-in capabilities of cut, copy, and paste - see the text man page. Only file I/O has to be added by us to make it really usable.
pack [scrollbar .y -command ".t yview"] -side right -fill y pack [text .t -wrap word -yscrollc ".y set"] -side right -fill both -expand 1
Are you targetting 8.4 or later? If so, add -undo 1 to the options to text and get full undo/redo support!
pack [text .t -wrap word -yscrollc ".y set" -undo 1] -side right -fill both -expand 1
The other important part of a GUI are the bindings - what event shall trigger what action. For simplicity, I've limited the bindings here to a few of the function keys on top of typical keyboards:
bind . <F1> {tk_messageBox -message $about}
Online help is done with a no-frills tk_messageBox with the "about" text defined at start of file. - The other bindings call custom commands, which get a filename argument from Tk's file selector dialogs:
bind . <F2> {loadText .t [tk_getOpenFile]}
bind . <F3> {saveText .t [tk_getSaveFile]}
These dialogs can also be configured in a number of ways, but even in this simple form they are quite powerful - allow navigation around the file system, etc. On Windows they call the native file selectors, which have a history of previously opened files, detail view (size/date etc.)
When this editor is called with a filename on the command line, that file is loaded on startup (simple as it is, it can only handle one file at a time):
if {$argv != ""} {loadText .t [lindex $argv 0]}
The procedures for loading and saving text both start with a sanity check of the filename argument - if it's an empty string, as produced by file selector dialogs when the user cancels, they return immediately. Otherwise, they transfer file content to text widget or vice-versa. loadText adds the "luxury" that the name of the current file is also put into the window title. Then it opens the file, clears the text widget, reads all file contents in one go, and puts them into the text widget.
proc loadText {w fn} {
if {$fn==""} return
wm title . [file tail $fn]
set fp [open $fn]
$w delete 1.0 end
$w insert end [read $fp]
close $fp
}
saveText takes care not to save the extra newline that text widgets append at end, by limiting the range to "end - 1 c"(haracter).
proc saveText {w fn} {
if {$fn==""} return
set fp [open $fn w]
puts -nonewline $fp [$w get 1.0 "end - 1 c"]
close $fp
}
File watch
editSome editors (e.g. PFE, MS Visual Studio) pop up an alert dialog when a file was changed on disk while being edited - that might lead to edit conflicts. Emacs shows a more subtle warning at the first attempt to change a file that has changed on disk.
Here I try to emulate this feature. It is oversimplified because it does not update the mtime (file modification time) to check, once you saved it from the editor itself. So make sure to call text'watch'file again after saving.
Using the global variable ::_twf it is at least possible to avoid false alarms - for a more serious implementation one might use a namespaced array of watchers, indexed by file name, in case you want multiple edit windows. }
proc text'watch'file {w file {mtime -}} {
set checkinterval 1000 ;# modify as needed
if {$mtime eq "-"} {
if [info exists ::_twf] {after cancel $::_twf}
set file [file join [pwd] $file]
text'watch'file $w $file [file mtime $file]
} else {
set newtime [file mtime $file]
if {$newtime != $mtime} {
set answer [tk_messageBox -type yesno -message \
"The file\n$file\nhas changed on disk. Reload it?"]
if {$answer eq "yes"} {text'read'file $w $file}
text'watch'file $w $file
} else {set ::_twf [after $checkinterval [info level 0]]}
}
}
proc text'read'file {w file} {
set f [open $file]
$w delete 1.0 end
$w insert end [read $f]
close $f
}
#-- Testing: pack [text .t -wrap word] -fill both -expand 1 set file textwatch.tcl text'read'file .t $file text'watch'file .t $file
The dialog should come up when you change the file externally, say by touch-ing it in pure Tcl, which might be done with editing it in another editor, or
file mtime $filename [clock seconds]
Tiny presentation graphics
editThis is a crude little canvas presentation graphics that runs on PocketPCs, but also on bigger boxes (one might scale fonts and dimensions there). Switch pages with Left/Right cursor, or left/right mouseclick (though a stylus cannot right-click).
Not many features, but the code is very compact, and with a cute little language for content specification, see example at end (which shows what I presented at the 2003 Euro-Tcl convention in Nuremberg...)}
proc slide args {
global slides
if {![info exist slides]} slide'init
incr slides(N)
set slides(title,$slides(N)) [join $args]
}
proc slide'line {type args} {
global slides
lappend slides(body,$slides(N)) [list $type [join $args]]
}
foreach name {* + -} {interp alias {} $name {} slide'line $name}
proc slide'init {} {
global slides
array set slides {
canvas .c N 0 show 1 dy 20
titlefont {Tahoma 22 bold} * {Tahoma 14 bold} + {Tahoma 12}
- {Courier 10}
}
pack [canvas .c -bg white] -expand 1 -fill both
foreach e {<1> <Right>} {bind . $e {slide'show 1}}
foreach e {<3> <Left>} {bind . $e {slide'show -1}}
wm geometry . +0+0
after idle {slide'show 0}
}
proc slide'show delta {
upvar #0 slides s
incr s(show) $delta
if {$s(show)<1 || $s(show)>$s(N)} {
incr s(show) [expr -$delta]
} else {
set c $s(canvas)
$c delete all
set x 10; set y 20
$c create text $x $y -anchor w -text $s(title,$s(show))\
-font $s(titlefont) -fill blue
incr y $s(dy)
$c create line $x $y 2048 $y -fill red -width 4
foreach line $s(body,$s(show)) {
foreach {type text} $line break
incr y $s(dy)
$c create text $x $y -anchor w -text $text \
-font $s($type)
}
}
}
bind . <Up> {exec wish $argv0 &; exit} ;# dev helper
The rest is data - or is it code? Anyway, here's my show:
slide i18n - Tcl for the world + Richard Suchenwirth, Nuremberg 2003 + * i18n: internationalization + 'make software work with many languages' + * l10n: localization + 'make software work with the local language'
slide Terminology * Glyphs: + visible elements of writing * Characters: + abstract elements of writing * Byte sequences: + physical text data representation * Rendering: character -> glyph * Encoding: character <-> byte sequence
slide Before Unicode * Bacon (1580), Baudot: 5-bit encodings * Fieldata (6 bits), EBCDIC (8 bits) * ASCII (7 bits) + world-wide "kernel" of encodings * 8-bit codepages: DOS, Mac, Windows * ISO 8859-x: 16 varieties
slide East Asia * Thousands of characters/country + Solution: use 2 bytes, 94x94 matrix + Japan: JIS C-6226/0208/0212 + China: GB2312-80 + Korea: KS-C 5601 + * coexist with ASCII in EUC encodings
slide Unicode covers all * Common standard of software industry * kept in synch with ISO 10646 + Used to be 16 bits, until U 3.1 + Now needs up to 31 bits * Byte order problem: + little-endian/big-endian + U+FEFF "Byte Order Mark" + U+FFFE --illegal--
slide UTF-8 * Varying length: 1..3(..6) bytes + 1 byte: ASCII + 2 bytes: pages 00..07, Alphabets + 3 bytes: pages 08..FF, rest of BMP + >3 bytes: higher pages + * Standard in XML, coming in Unix
slide Tcl i18n
* Everything is a Unicode string (BMP)
+ internal rep: UTF-8/UCS-2
* Important commands:
- fconfigure \$ch -encoding \$e
- encoding convertfrom \$e \$s
- encoding convertto \$e \$s
+
* msgcat supports l10n:
- {"File" -> [mc "File"]}
slide Tk i18n * Any widget text is Unicoded * Automatic font finding + Fonts must be provided by system + * Missing: bidi treatment + right-to-left conversion (ar,he)
slide Input i18n
* Keyboard rebinding (bindtags)
* East Asia: keyboard buffering
+ Menu selection for ambiguities
+
* Virtual keyboard (buttons, canvas)
* String conversion: *lish family
- {[ruslish Moskva]-[greeklish Aqh'nai]}
slide i18n - Tcl for the world + + + Thank you.
Timeline display
editYet another thing to do with a canvas: history visualisation of a horizontal time-line, for which a year scale is displayed on top. The following kinds of objects are so far available:
- "eras", displayed in yellow below the timeline in boxes
- "background items" that are grey and stretch over all the canvas in height
- normal items, which get displayed as stacked orange bars
You can zoom in with <1>, out with <3> (both only in x direction). On mouse motion, the current year is displayed in the toplevel's title. Normal items can be a single year, like the Columbus example, or a range of years, for instance for lifetimes of persons. (The example shows that Mozart didn't live long...)
namespace eval timeliner {
variable ""
array set "" {-zoom 1 -from 0 -to 2000}
}
proc timeliner::create {w args} {
variable ""
array set "" $args
#-- draw time scale
for {set x [expr ($(-from)/50)*50]} {$x<=$(-to)} {incr x 10} {
if {$x%50 == 0} {
$w create line $x 8 $x 0
$w create text $x 8 -text $x -anchor n
} else {
$w create line $x 5 $x 0
}
}
bind $w <Motion> {timeliner::title %W %x ; timeliner::movehair %W %x}
bind $w <1> {timeliner::zoom %W %x 1.25}
bind $w <2> {timeliner::hair %W %x}
bind $w <3> {timeliner::zoom %W %x 0.8}
}
proc timeliner::movehair {w x} {
variable ""
if {[llength [$w find withtag hair]]} {
set x [$w canvasx $x]
$w move hair [expr {$x - $(x)}] 0
set (x) $x
}
}
proc timeliner::hair {w x} {
variable ""
if {[llength [$w find withtag hair]]} {
$w delete hair
} else {
set (x) [$w canvasx $x]
$w create line $(x) 0 $(x) [$w cget -height] \
-tags hair -width 1 -fill red
}
}
proc timeliner::title {w x} {
variable ""
wm title . [expr int([$w canvasx $x]/$(-zoom))]
}
proc timeliner::zoom {w x factor} {
variable ""
$w scale all 0 0 $factor 1
set (-zoom) [expr {$(-zoom)*$factor}]
$w config -scrollregion [$w bbox all]
if {[llength [$w find withtag hair]]} {
$w delete hair
set (x) [$w canvasx $x]
$w create line $(x) 0 $(x) [$w cget -height] \
-tags hair -width 1 -fill red
}
}
This command adds an object to the canvas. The code for "item" took me some effort, as it had to locate a free "slot" on the canvas, searching top-down:
proc timeliner::add {w type name time args} {
variable ""
regexp {(\d+)(-(\d+))?} $time -> from - to
if {$to eq ""} {set to $from}
set x0 [expr {$from*$(-zoom)}]
set x1 [expr {$to*$(-zoom)}]
switch -- $type {
era {set fill yellow; set outline black; set y0 20; set y1 40}
bgitem {set fill gray; set outline {}; set y0 40; set y1 1024}
item {
set fill orange
set outline yellow
for {set y0 60} {$y0<400} {incr y0 20} {
set y1 [expr {$y0+18}]
if {[$w find overlap [expr $x0-5] $y0 $x1 $y1] eq ""} break
}
}
}
set id [$w create rect $x0 $y0 $x1 $y1 -fill $fill -outline $outline]
if {$type eq "bgitem"} {$w lower $id}
set x2 [expr {$x0+5}]
set y2 [expr {$y0+2}]
set tid [$w create text $x2 $y2 -text $name -anchor nw]
foreach arg $args {
if {$arg eq "!"} {
$w itemconfig $tid -font "[$w itemcget $tid -font] bold"
}
}
$w config -scrollregion [$w bbox all]
}
Here's a sample application, featuring a concise history of music in terms of composers:
scrollbar .x -ori hori -command {.c xview}
pack .x -side bottom -fill x
canvas .c -bg white -width 600 -height 300 -xscrollcommand {.x set}
pack .c -fill both -expand 1
timeliner::create .c -from 1400 -to 2000
These nifty shorthands for adding items make data specification a breeze - compare the original call, and the shorthand:
timeliner::add .c item Purcell 1659-1695 - Purcell 1659-1695
With an additional "!" argument you can make the text of an item bold:
foreach {shorthand type} {* era x bgitem - item} {
interp alias {} $shorthand {} timeliner::add .c $type
}
Now for the data to display (written pretty readably):
* {Middle Ages} 1400-1450
- Dufay 1400-1474
* Renaissance 1450-1600
- Desprez 1440-1521
- Luther 1483-1546
- {Columbus discovers America} 1492
- Palestrina 1525-1594 !
- Lasso 1532-1594
- Byrd 1543-1623
* Baroque 1600-1750
- Dowland 1563-1626
- Monteverdi 1567-1643
- Schütz 1585-1672
- Purcell 1659-1695
- Telemann 1681-1767
- Rameau 1683-1764
- Bach,J.S. 1685-1750 !
- Händel 1685-1759
x {30-years war} 1618-1648
* {Classic era} 1750-1810
- Haydn 1732-1809 !
- Boccherini 1743-1805
- Mozart 1756-1791 !
- Beethoven 1770-1828 !
* {Romantic era} 1810-1914
- {Mendelssohn Bartholdy} 1809-1847
- Chopin 1810-1849
- Liszt 1811-1886
- Verdi 1813-1901
x {French revolution} 1789-1800
* {Modern era} 1914-2000
- Ravel 1875-1937 !
- Bartók 1881-1945
- Stravinskij 1882-1971
- Varèse 1883-1965
- Prokof'ev 1891-1953
- Milhaud 1892-1974
- Honegger 1892-1955
- Hindemith 1895-1963
- Britten 1913-1976
x WW1 1914-1918
x WW2 1938-1945
Fun with functions
edit
My teenage daughter hates math. In order to motivate her, I beefed up an earlier little function plotter which before only took one function, in strict Tcl (expr) notation, from the command line. Now there's an entry widget, and the accepted language has also been enriched: beyond exprs rules, you can omit dollar and multiplication signs, like 2x+1, powers can be written as x3 instead of ($x*$x*$x); in simple cases you can omit parens round function arguments, like sin x2. Hitting <Return> in the entry widget displays the function's graph.
If you need some ideas, click on the "?" button to cycle through a set of demo functions, from boring to bizarre (e.g. if rand() is used). Besides default scaling, you can zoom in or out. Moving the mouse pointer over the canvas displays x and y coordinates, and the display changes to white if you're on a point on the curve.
The target was not reached: my daughter still hates math. But at least I had hours of Tcl (and function) fun again, surfing in the Cartesian plane... hope you enjoy it too!
proc main {} {
canvas .c -bg white -borderwidth 0
bind .c <Motion> {displayXY .info %x %y}
frame .f
label .f.1 -text "f(x) = "
entry .f.f -textvar ::function -width 40
bind .f.f <Return> {plotf .c $::function}
button .f.demo -text " ? " -pady 0 -command {demo .c}
label .f.2 -text " Zoom: "
entry .f.fac -textvar ::factor -width 4
set ::factor 32
bind .f.fac <Return> {zoom .c 1.0}
button .f.plus -text " + " -pady 0 -command {zoom .c 2.0}
button .f.minus -text " - " -pady 0 -command {zoom .c 0.5}
eval pack [winfo children .f] -side left -fill both
label .info -textvar ::info -just left
pack .info .f -fill x -side bottom
pack .c -fill both -expand 1
demo .c
}
set ::demos {
"cos x3" 2 1-x 0.5x2 x3/5 "sin x" "sin x2" 1/x sqrt(x)
"tan x/5" x+1/x x abs(x) "exp x" "log x" "log x2"
round(x) "int x%2" "x-int x" "0.2tan x+1/tan x" x*(rand()-0.5)
x2/5-1/(2x) "atan x" sqrt(1-x2) "abs(x-int(x*2))" (x-1)/(x+1)
"sin x-tan x" "sin x-tan x2" "x-abs(int x)" 0.5x-1/x
-0.5x3+x2+x-1 3*sin(2x) -0.05x4-0.2x3+1.5x2+2x-3 "9%int x"
0.5x2/(x3-3x2+4) "abs x2-3 int x" "int x%3"
}
proc displayXY {w cx cy} {
set x [expr {double($cx-$::dx)/$::factor}]
set y [expr {double(-$cy+$::dy)/$::factor}]
set ::info [format "x=%.2f y=%.2f" $x $y]
catch {
$w config -fg [expr {abs([expr $::fun]-$y)<0.01?"white":"black"}]
} ;# may divide by zero, or other illegal things
}
proc zoom {w howmuch} {
set ::factor [expr round($::factor*$howmuch)]
plotf $w $::function
}
proc plotf {w function} {
foreach {re subst} {
{([a-z]) +(x[0-9]?)} {\1(\2)} " " "" {([0-9])([a-z])} {\1*\2}
x2 x*x x3 x*x*x x4 x*x*x*x x \$x {e\$xp} exp
} {regsub -all $re $function $subst function}
set ::fun $function
set ::info "Tcl: expr $::fun"
set color [lpick {red blue purple brown green}]
plotline $w [fun2points $::fun] -fill $color
}
proc lpick L {lindex $L [expr {int(rand()*[llength $L])}]}
proc fun2points {fun args} {
array set opt {-from -10.0 -to 10.0 -step .01}
array set opt $args
set res "{"
for {set x $opt(-from)} {$x<= $opt(-to)} {set x [expr {$x+$opt(-step)}]} {
if {![catch {expr $fun} y]} {
if {[info exists lasty] && abs($y-$lasty)>100} {
append res "\} \{" ;# incontinuity
}
append res " $x $y"
set lasty $y
} else {append res "\} \{"}
}
append res "}"
}
proc plotline {w points args} {
$w delete all
foreach i $points {
if {[llength $i]>2} {eval $w create line $i $args -tags f}
}
set fac $::factor
$w scale all 0 0 $fac -$fac
$w create line -10000 0 10000 0 ;# X axis
$w create line 0 -10000 0 10000 ;# Y axis
$w create line $fac 0 $fac -3 ;# x=1 tick
$w create line -3 -$fac 0 -$fac ;# y=1 tick
set ::dx [expr {[$w cget -width]/2}]
set ::dy [expr {[$w cget -height]/2}]
$w move all $::dx $::dy
$w raise f
}
proc demo {w} {
set ::function [lindex $::demos 0] ;# cycle through...
set ::demos [concat [lrange $::demos 1 end] [list $::function]]
set ::factor 32
plotf $w $::function
}
main
Functional imaging
editIn Conal Elliott's Pan project ("Functional Image Synthesis", [1]), images (of arbitrary size and resolution) are produced and manipulated in an elegant functional way. Functions written in Haskell (see Playing Haskell) are applied, mostly in functional composition, to pixels to return their color value. FAQ: "Can we have that in Tcl too?"
As the funimj demo below shows, in principle yes; but it takes some patience (or a very fast CPU) - for a 200x200 image the function is called 40000 times, which takes 9..48 seconds on my P200 box. Still, the output often is worth waiting for... and the time used to write this code was negligible, as the Haskell original could with few modifications be represented in Tcl. Functional composition had to be rewritten to Tcl's Polish notation - Haskell's
foo 1 o bar 2 o grill
(where "o" is the composition operator) would in Tcl look like
o {foo 1} {bar 2} grill
As the example shows, additional arguments can be specified; only the last argument is passed through the generated "function nest":
proc f {x} {foo 1 [bar 2 [grill $x]]}
But the name of the generated function is much nicer than "f": namely, the complete call to "o" is used, so the example proc has the name
"o {foo 1} {bar 2} grill"
which is pretty self-documenting ;-) I implemented "o" like this:
proc o args {
# combine the functions in args, return the created name
set name [info level 0]
set body "[join $args " \["] \$x"
append body [string repeat \] [expr {[llength $args]-1}]]
proc $name x $body
set name
}
# Now for the rendering framework:
proc fim {f {zoom 100} {width 200} {height -}} {
# produce a photo image by applying function f to pixels
if {$height=="-"} {set height $width}
set im [image create photo -height $height -width $width]
set data {}
set xs {}
for {set j 0} {$j<$width} {incr j} {
lappend xs [expr {($j-$width/2.)/$zoom}]
}
for {set i 0} {$i<$height} {incr i} {
set row {}
set y [expr {($i-$height/2.)/$zoom}]
foreach x $xs {
lappend row [$f [list $x $y]]
}
lappend data $row
}
$im put $data
set im
}
Basic imaging functions ("drawers") have the common functionality point -> color, where point is a pair {x y} (or, after applying a polar transform, {r a}...) and color is a Tk color name, like "green" or #010203:
proc vstrip p {
# a simple vertical bar
b2c [expr {abs([lindex $p 0]) < 0.5}]
}
proc udisk p {
# unit circle with radius 1
foreach {x y} $p break
b2c [expr {hypot($x,$y) < 1}]
}
proc xor {f1 f2 p} {
lappend f1 $p; lappend f2 $p
b2c [expr {[eval $f1] != [eval $f2]}]
}
proc and {f1 f2 p} {
lappend f1 $p; lappend f2 $p
b2c [expr {[eval $f1] == "#000" && [eval $f2] == "#000"}]
}
proc checker p {
# black and white checkerboard
foreach {x y} $p break
b2c [expr {int(floor($x)+floor($y)) % 2 == 0}]
}
proc gChecker p {
# greylevels correspond to fractional part of x,y
foreach {x y} $p break
g2c [expr {(fmod(abs($x),1.)*fmod(abs($y),1.))}]
}
proc bRings p {
# binary concentric rings
foreach {x y} $p break
b2c [expr {round(hypot($x,$y)) % 2 == 0}]
}
proc gRings p {
# grayscale concentric rings
foreach {x y} $p break
g2c [expr {(1 + cos(3.14159265359 * hypot($x,$y))) / 2.}]
}
proc radReg {n p} {
# n wedge slices starting at (0,0)
foreach {r a} [toPolars $p] break
b2c [expr {int(floor($a*$n/3.14159265359))%2 == 0}]
}
proc xPos p {b2c [expr {[lindex $p 0]>0}]}
proc cGrad p {
# color gradients - best watched at zoom=100
foreach {x y} $p break
if {abs($x)>1.} {set x 1.}
if {abs($y)>1.} {set y 1.}
set r [expr {int((1.-abs($x))*255.)}]
set g [expr {int((sqrt(2.)-hypot($x,$y))*180.)}]
set b [expr {int((1.-abs($y))*255.)}]
c2c $r $g $b
}
Beyond the examples in Conal Elliott's paper, I found out that function imaging can also be abused for a (slow and imprecise) function plotter, which displays the graph for y = f(x) if you call it with $y + f($x) as first argument:
proc fplot {expr p} {
foreach {x y} $p break
b2c [expr abs($expr)<=0.04] ;# double eval required here!
}
Here is a combinator for two binary images that shows in different colors for which point both or either are "true" - nice but slow:}
proc bin2 {f1 f2 p} {
set a [eval $f1 [list $p]]
set b [eval $f2 [list $p]]
expr {
$a == "#000" ?
$b == "#000" ? "green"
: "yellow"
: $b == "#000" ? "blue"
: "black"
}
}
#--------------------------------------- Pixel converters:
proc g2c {greylevel} {
# convert 0..1 to #000000..#FFFFFF
set hex [format %02X [expr {round($greylevel*255)}]]
return #$hex$hex$hex
}
proc b2c {binpixel} {
# 0 -> white, 1 -> black
expr {$binpixel? "#000" : "#FFF"}
}
proc c2c {r g b} {
# make Tk color name: {0 128 255} -> #0080FF
format #%02X%02X%02X $r $g $b
}
proc bPaint {color0 color1 pixel} {
# convert a binary pixel to one of two specified colors
expr {$pixel=="#000"? $color0 : $color1}
}
This painter colors a grayscale image in hues of the given color. It normalizes the given color through dividing by the corresponding values for "white", but appears pretty slow too:
proc gPaint {color pixel} {
set abspixel [lindex [rgb $pixel] 0]
set rgb [rgb $color]
set rgbw [rgb white]
foreach var {r g b} in $rgb ref $rgbw {
set $var [expr {round(double($abspixel)*$in/$ref/$ref*255.)}]
}
c2c $r $g $b
}
This proc caches the results of [winfo rgb] calls, because these are quite expensive, especially on remote X displays - rmax
proc rgb {color} {
upvar "#0" rgb($color) rgb
if {![info exists rgb]} {set rgb [winfo rgb . $color]}
set rgb
}
#------------------------------ point -> point transformers
proc fromPolars p {
foreach {r a} $p break
list [expr {$r*cos($a)}] [expr {$r*sin($a)}]
}
proc toPolars p {
foreach {x y} $p break
# for Sun, we have to make sure atan2 gets no two 0's
list [expr {hypot($x,$y)}] [expr {$x||$y? atan2($y,$x): 0}]
}
proc radInvert p {
foreach {r a} [toPolars $p] break
fromPolars [list [expr {$r? 1/$r: 9999999}] $a]
}
proc rippleRad {n s p} {
foreach {r a} [toPolars $p] break
fromPolars [list [expr {$r*(1.+$s*sin($n*$a))}] $a]
}
proc slice {n p} {
foreach {r a} $p break
list $r [expr {$a*$n/3.14159265359}]
}
proc rotate {angle p} {
foreach {x y} $p break
set x1 [expr {$x*cos(-$angle) - $y*sin(-$angle)}]
set y1 [expr {$y*cos(-$angle) + $x*sin(-$angle)}]
list $x1 $y1
}
proc swirl {radius p} {
foreach {x y} $p break
set angle [expr {hypot($x,$y)*6.283185306/$radius}]
rotate $angle $p
}
Now comes the demo program. It shows the predefined basic image operators, and some combinations, on a button bar. Click on one, have some patience, and the corresponding image will be displayed on the canvas to the right. You can also experiment with image operators in the entry widget at bottom - hit <Return> to try. The text of sample buttons is also copied to the entry widget, so you can play with the parameters, or rewrite it as you wish. Note that a well-formed funimj composition consists of:
- the composition operator "o"
- zero or more "painters" (color -> color)
- one "drawer" (point -> color)
- zero or more "transformers" (point -> point)
}
proc fim'show {c f} {
$c delete all
set ::try $f ;# prepare for editing
set t0 [clock seconds]
. config -cursor watch
update ;# to make the cursor visible
$c create image 0 0 -anchor nw -image [fim $f $::zoom]
wm title . "$f: [expr [clock seconds]-$t0] seconds"
. config -cursor {}
}
proc fim'try {c varName} {
upvar #0 $varName var
$c delete all
if [catch {fim'show $c [eval $var]}] {
$c create text 10 10 -anchor nw -text $::errorInfo
}
}
Composed functions need only be mentioned once, which creates them, and they can later be picked up by info procs. The o looks nicely bullet-ish here..
o bRings
o cGrad
o checker
o gRings
o vstrip
o xPos
o {bPaint brown beige} checker
o checker {slice 10} toPolars
o checker {rotate 0.1}
o vstrip {swirl 1.5}
o checker {swirl 16}
o {fplot {$y + exp($x)}}
o checker radInvert
o gRings {rippleRad 8 0.3}
o xPos {swirl .75}
o gChecker
o {gPaint red} gRings
o {bin2 {radReg 7} udisk}
#----------------------------------------------- testing
frame .f2
set c [canvas .f2.c]
set e [entry .f2.e -bg white -textvar try]
bind $e <Return> [list fim'try $c ::try]
scale .f2.s -from 1 -to 100 -variable zoom -ori hori -width 6
#--------------------------------- button bar:
frame .f
set n 0
foreach imf [lsort [info procs "o *"]] {
button .f.b[incr n] -text $imf -anchor w -pady 0 \
-command [list fim'show $c $imf]
}
set ::zoom 25
eval pack [winfo children .f] -side top -fill x -ipady 0
eval pack [winfo children .f2] -side top -fill x
pack .f .f2 -side left -anchor n
bind . <Escape> {exec wish $argv0 &; exit} ;# dev helper
bind . ? {console show} ;# dev helper, Win/Mac only
TkPhotoLab
editThe following code can be used for experiments in image processing, including
- convolutions (see below)
- conversion from color to greylevel
- conversion from greylevel to faux color
- brightness and contrast modification
Tcl is not the fastest in heavy number-crunching, as needed when going over many thousands of pixels, but I wouldn't consider C for a fun project ;) So take your time, or get a real CPU. At least you can watch the progress, as the target image is updated after every row.
Edge enhancement by Laplace5 filter
The demo UI shows two images, the original on the left, the processing result on the right. You can push the result to the left with Options/Accept. See the menus for what goodies I have supplied. But what most interested me were "convolutions", for which you can edit the matrix (fixed at 3x3 - slow enough..) and click "Apply" to run it over the input image. "C" to set the matrix to all zeroes.
Convolution is a technique where a target pixel is colored according to the sum of the product of a given matrix and its neighbors. As an example, the convolution matrix
1 1 1 1 1 1 1 1 1
colors the pixel in the middle with the average of itself and its eight neighbors, which will myopically blur the picture.
0 0 0 0 1 0 0 0 0
should just faithfully repeat the input picture. These
0 -1 0 -1 -1 -1 -1 5 -1 or: -1 9 -1 0 -1 0 -1 -1 -1
enhance {horizont,vertic}al edges, and make the image look "crispier". }
proc convolute {inimg outimg matrix} {
set w [image width $inimg]
set h [image height $inimg]
set matrix [normalize $matrix]
set shift [expr {[matsum $matrix]==0? 128: 0}]
set imat [photo2matrix $inimg]
for {set i 1} {$i<$h-1} {incr i} {
set row {}
for {set j 1} {$j<$w-1} {incr j} {
foreach var {rsum gsum bsum} {set $var 0.0}
set y [expr {$i-1}]
foreach k {0 1 2} {
set x [expr {$j-1}]
foreach l {0 1 2} {
if {[set fac [lindex $matrix $k $l]]} {
foreach {r g b} [lindex $imat $y $x] {}
set rsum [expr {$rsum + $r * $fac}]
set gsum [expr {$gsum + $g * $fac}]
set bsum [expr {$bsum + $b * $fac}]
}
incr x
}
incr y
}
if {$shift} {
set rsum [expr {$rsum + $shift}]
set gsum [expr {$gsum + $shift}]
set bsum [expr {$bsum + $shift}]
}
lappend row [rgb [clip $rsum] [clip $gsum] [clip $bsum]]
}
$outimg put [list $row] -to 1 $i
update idletasks
}
}
proc alias {name args} {eval [linsert $args 0 interp alias {} $name {}]}
alias rgb format #%02x%02x%02x
proc lambda {argl body} {K [set n [info level 0]] [proc $n $argl $body]}
proc K {a b} {set a}
proc clip x {expr {$x>255? 255: $x<0? 0: int($x)}}
proc photo2matrix image {
set w [image width $image]
set h [image height $image]
set res {}
for {set y 0} {$y<$h} {incr y} {
set row {}
for {set x 0} {$x<$w} {incr x} {
lappend row [$image get $x $y]
}
lappend res $row
}
set res
}
proc normalize matrix {
#-- make sure all matrix elements add up to 1.0
set sum [matsum $matrix]
if {$sum==0} {return $matrix} ;# no-op on zero sum
set res {}
foreach inrow $matrix {
set row {}
foreach el $inrow {lappend row [expr {1.0*$el/$sum}]}
lappend res $row
}
set res
}
proc matsum matrix {expr [join [join $matrix] +]}
The following routines could also be generified into one:
proc color2gray image {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$image get $j $i] break
set y [expr {int(0.299*$r + 0.587*$g + 0.114*$b)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 $i
update idletasks
}
}
proc color2gray2 image {
set i -1
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
foreach {r g b} $pixel break
set y [expr {int(($r + $g + $b)/3.)}]
lappend row [rgb $y $y $y]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}
An experiment in classifying graylevels into unreal colors:
proc gray2color image {
set i -1
set colors {black darkblue blue purple red orange yellow white}
set n [llength $colors]
foreach inrow [photo2matrix $image] {
set row {}
foreach pixel $inrow {
set index [expr {[lindex $pixel 0]*$n/256}]
lappend row [lindex $colors $index]
}
$image put [list $row] -to 0 [incr i]
update idletasks
}
}
proc grayWedge image {
$image blank
for {set i 0} {$i<256} {incr i} {
$image put [rgb $i $i $i] -to $i 0 [expr {$i+1}] 127
}
}
A number of algorithms are very similar, distinguished only by a few commands in the center. Hence I made them generic, and they take a function name that is applied to every pixel rgb, resp. a pair of pixel rgb's. They are instantiated by an alias that sets the function fancily as a lambda:
proc generic_1 {f target source} {
set w [image width $source]
set h [image height $source]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$source get $j $i] break
lappend row [rgb [$f $r] [$f $g] [$f $b]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias invert generic_1 [lambda x {expr {255-$x}}]
alias contrast+ generic_1 [lambda x {clip [expr {128+($x-128)*1.25}]}]
alias contrast- generic_1 [lambda x {clip [expr {128+($x-128)*0.8}]}]
proc generic_2 {f target with} {
set w [image width $target]
set h [image height $target]
for {set i 0} {$i<$h} {incr i} {
set row {}
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$target get $j $i] break
foreach {r1 g1 b1} [$with get $j $i] break
lappend row [rgb [$f $r $r1] [$f $g $g1] [$f $b $b1]]
}
$target put [list $row] -to 0 $i
update idletasks
}
}
alias blend generic_2 [lambda {a b} {expr {($a+$b)/2}}]
alias difference generic_2 [lambda {a b} {expr {255-abs($a-$b)}}]
A histogram is a count of which color value occurred how often in the current image, separately for red, green and blue. For graylevel images, the displayed "curves" should exactly overlap, so you see only the blue dots that are drawn last.
proc histogram {image {channel 0}} {
set w [image width $image]
set h [image height $image]
for {set i 0} {$i<256} {incr i} {set hist($i) 0}
for {set i 0} {$i<$h} {incr i} {
for {set j 0} {$j<$w} {incr j} {
incr hist([lindex [$image get $j $i] $channel])
}
}
set res {}
for {set i 0} {$i<256} {incr i} {lappend res $hist($i)}
set res
}
proc drawHistogram {target input} {
$target blank
set a [expr {6000./([image height $input]*[image width $input])}]
foreach color {red green blue} channel {0 1 2} {
set i -1
foreach val [histogram $input $channel] {
$target put $color -to [incr i] \
[clip [expr {int(128-$val*$a)}]]
}
update idletasks
}
}
Demo UI:
if {[file tail [info script]] eq [file tail $argv0]} {
package require Img ;# for JPEG etc.
proc setFilter {w matrix} {
$w delete 1.0 end
foreach row $matrix {$w insert end [join $row \t]\n}
set ::info "Click 'Apply' to use this filter"
}
label .title -text TkPhotoLab -font {Helvetica 14 italic} -fg blue
label .( -text ( -font {Courier 32}
set txt [text .t -width 20 -height 3]
setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}
label .) -text ) -font {Courier 32}
button .c -text C -command {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
grid .title .( .t .) .c -sticky news
button .apply -text Apply -command applyConv
grid x ^ ^ ^ .apply -sticky ew
grid [label .0 -textvar info] - - -sticky w
grid [label .1] - [label .2] - - -sticky new
proc loadImg { {fn ""}} {
if {$fn==""} {set fn [tk_getOpenFile]}
if {$fn != ""} {
cd [file dirname [file join [pwd] $fn]]
set ::im1 [image create photo -file $fn]
.1 config -image $::im1
set ::im2 [image create photo]
.2 config -image $::im2
$::im2 copy $::im1 -shrink
set ::info "Loaded image 1 from $fn"
}
}
proc saveImg { {fn ""}} {
if {$fn==""} {set fn [tk_getSaveFile]}
if {$fn != ""} {
$::im2 write $fn -format JPEG
set ::info "Saved image 2 to $fn"
}
}
proc applyConv {} {
set ::info "Convolution running, have patience..."
set t0 [clock clicks -milliseconds]
convolute $::im1 $::im2 [split [$::txt get 1.0 end] \n]
set dt [expr {([clock click -milliseconds]-$t0)/1000.}]
set ::info "Ready after $dt sec"
}
A little wrapper for simplified menu creation - see below for its use:
proc m+ {head name {cmd ""}} {
if {![winfo exists .m.m$head]} {
.m add cascade -label $head -menu [menu .m.m$head -tearoff 0]
}
if [regexp ^-+$ $name] {
.m.m$head add separator
} else {.m.m$head add command -label $name -comm $cmd}
}
. config -menu [menu .m] m+ File Open.. loadImg m+ File Save.. saveImg m+ File --- m+ File Exit exit
m+ Edit Blend {blend $im2 $im1}
m+ Edit Difference {difference $im2 $im1}
m+ Edit ---
m+ Edit Negative {invert $im2 $im1}
m+ Edit Contrast+ {contrast+ $im2 $im1}
m+ Edit Contrast- {contrast- $im2 $im1}
m+ Edit ---
m+ Edit Graylevel {$im2 copy $im1 -shrink; color2gray $im2}
m+ Edit Graylevel2 {$im2 copy $im1 -shrink; color2gray2 $im2}
m+ Edit "Add Noise" {
generic_1 [lambda x {expr {rand()<.01? int(rand()*255):$x}}] $im2 $im1
}
m+ Edit gray2color {$im2 copy $im1 -shrink; gray2color $im2}
m+ Edit Octary {generic_1 [lambda x {expr {$x>127? 255:0}}] $im2 $im1}
m+ Edit ---
m+ Edit HoriMirror {$im2 copy $im1 -shrink -subsample -1 1}
m+ Edit VertMirror {$im2 copy $im1 -shrink -subsample 1 -1}
m+ Edit "Upside down" {$im2 copy $im1 -shrink -subsample -1 -1}
m+ Edit ---
m+ Edit "Zoom x 2" {$im2 copy $im1 -shrink -zoom 2}
m+ Edit "Zoom x 3" {$im2 copy $im1 -shrink -zoom 3}
m+ Options "Accept (1<-2)" {$im1 copy $im2 -shrink}
m+ Options ---
m+ Options "Gray wedge" {grayWedge $im2}
m+ Options Histogram {drawHistogram $im2 $im1}
m+ Filter Clear {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
m+ Filter ---
m+ Filter Blur0 {setFilter .t {{1 1 1} {1 0 1} {1 1 1}}}
m+ Filter Blur1 {setFilter .t {{1 1 1} {1 1 1} {1 1 1}}}
m+ Filter Gauss2 {setFilter .t {{1 2 1} {2 4 2} {1 2 1}}}
m+ Filter ---
m+ Filter Laplace5 {setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}}
m+ Filter Laplace9 {setFilter .t {{-1 -1 -1} {-1 9 -1} {-1 -1 -1}}}
m+ Filter LaplaceX {setFilter .t {{1 -2 1} {-2 5 -2} {1 -2 1}}}
m+ Filter ---
m+ Filter Emboss {setFilter .t {{2 0 0} {0 -1 0} {0 0 -1}}}
m+ Filter HoriEdge {setFilter .t {{-1 -1 -1} {0 0 0} {1 1 1}}}
m+ Filter VertEdge {setFilter .t {{-1 0 1} {-1 0 1} {-1 0 1}}}
m+ Filter SobelH {setFilter .t {{1 2 1} {0 0 0} {-1 -2 -1}}}
m+ Filter SobelV {setFilter .t {{1 0 -1} {2 0 -2} {1 0 -1}}}
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}
loadImg aaa.jpg
}