# Tcl Programming/Tk

### Introduction

The Tk (Tool Kit) is the most popular Tcl extension for designing
graphical user interfaces (GUI) on Macintosh, Unix/Linux, or Windows
operating systems.

With little effort, it allows to put together useful

-   windows (forms, as some call them) consisting of
-   *widgets*, which are managed by
-   *geometry managers*. Also, you can easily define
-   bindings of mouse or keyboard events to trigger the actions you
    want.

#### Example: calculator

Here is a very simple, complete Tcl/Tk script that implements a
calculator:

`package require Tk`\
`pack [entry .e -textvar e -width 50]`\
`bind .e ``<Return>`{=html}` {`\
`   set e  [regsub { *=.*} $e ""] ;# remove evaluation (Chris)`\
`   catch {expr [string map {/ *1./} $e]} res`\
`   append e " = $res"`\
`} `

It creates an *entry* widget named *.e*, into which you can type from
the keyboard, with an associated variable *e* (which will mirror the
entry\'s content), and manages it with *pack*.

One binding is defined: if with keyboard focus on .e, the
`<Return>`{=html} key is hit, then

-   all division operators (/) in the variable *e* are mapped to
    \"\*1./\" (this forces floating point division),
-   the resulting string is fed to *expr* to evaluate it as an
    arithmetic/logic expression
-   as there may be errors in the user input, the *expr* call is wrapped
    into a *catch* which assigns either the result of *expr*, or the
    error message if one occurred, into the variable *res*
-   the result of the last evaluation is cleared by deleting everything
    after *=*
-   finally, an equal sign and the value of the *res* variable are
    *append*ed to *e*, making input and result immediately visible in
    the entry.

#### Example: a tiny IRC client

As before in the Tcl section, here\'s a working little script again: a
client for IRC (Internet Relay Chat) in 38 lines of code, that features
a **text** and an **entry** widget:

![](Picoirc.gif "Picoirc.gif")

`package require Tk`\
`set ::server irc.freenode.org`\
`set ::chan   #tcl`\
`set ::me     $tcl_platform(user)`\
`text .t -height 30 -wrap word -font {Arial 9}`\
`.t tag config bold   -font [linsert [.t cget -font] end bold]`\
`.t tag config italic -font [linsert [.t cget -font] end italic]`\
`.t tag config blue   -foreground blue`\
`entry .cmd`\
`pack .cmd -side bottom -fill x`\
`pack .t -fill both -expand 1`\
`bind .cmd ``<Return>`{=html}` post`\
`proc recv {} {`\
`    gets $::fd line`\
`    if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \`\
`        nick target msg]} {`\
`        set tag ""`\
`        if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic}`\
`        if [in {azbridge ijchain} $nick] {regexp {<([^>]+)>(.+)} $msg -> nick msg}`\
`       .t insert end $nick\t bold $msg\n $tag`\
`    } else {.t insert end $line\n italic}`\
`    .t yview end`\
`}`\
`proc in {list element} {expr {[lsearch -exact $list $element]>=0}}`\
`proc post {} {`\
`    set msg [.cmd get]`\
`    if [regexp {^/me (.+)} $msg -> action] {set msg "\001ACTION $action\001"}`\
`    foreach line [split $msg \n] {send "PRIVMSG $::chan :$line"}`\
`    .cmd delete 0 end`\
`    set tag ""`\
`    if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic}`\
`    .t insert end $::me\t {bold blue} $msg\n [list blue $tag]`\
`    .t yview end`\
`}`\
`proc send str {puts $::fd $str; flush $::fd}`\
`set ::fd [socket $::server 6667]`\
`send "NICK $::me"`\
`send "USER $::me 0 * :PicoIRC user"`\
`send "JOIN $::chan"`\
`fileevent $::fd readable recv`\
`bind . ``<Escape>`{=html}` {exec wish $argv0 &; exit}`

The last line is a quick debugging helper: if you modified the script in
the editor, save to disk, then hit `<Escape>`{=html} in the app to start
it anew.

### Widgets

Widgets are GUI objects that, when mapped by a geometry manager,
correspond to a rectangular area on the screen, with different
properties and capabilities.

Widgets are named with *path* names, somehow resembling file system path
names, except that the separator for widgets is a period \".\". For
example, *.foo.bar* is a child of *foo* which is a child of \".\"
Parent-child relation occurs typically with containers, e.g. *toplevel,
frame, canvas, text*. The name parts (i.e. between the dots) can be
almost any string that does not contain \".\" of course, or starts with
a Capital Letter (this is because widget class names with capital
initial have a special meaning, they denote class-wide options).

If you have a proc that takes a parent widget *w* and adds children, it
may be important to distinguish whether *w* is \".\" or another -
because you can\'t concatenate a child widget name directly to \".\" -
\$w.kid will make an invalid name if \$w == \".\". Here\'s how to avoid
this:

`set w2 [expr {$w eq "."? "": $w}]`\
`button $w2.$kid ...`

Widgets are created by a command named after their class, which then
takes the path name (requiring that parent widgets have to exist by that
time) and any number of *-key value* options that make up the original
configuration, e.g.

`button .b -text "Hello!" -command {do something}`

After creation, communication with the widget goes via a created command
that corresponds to its name. For instance, the configuration options
can be queried

`set text [.b cget -text]`

or changed

`.b configure -text Goodbye! -background red`

Some \"methods\" like *cget, configure* are generic to all widget
classes, others are specific to one or a few. For instance, both
\'text*and*entry*accept the*insert\'\' method. See the manual pages for
all the details.

Widgets appear on screen only after they have been given to a **geometry
manager** (see more below). Example:

`text .t -wrap word`\
`pack .t -fill both -expand 1`

As widget creation commands return the pathname, these two steps can
also be nested like

`pack [text .t -wrap word] -fill both -expand 1`

The **destroy** command deletes a widget and all of its child widgets,
if present:

`destroy .b`

The following sub-chapters describe the widgets available in Tk.

------------------------------------------------------------------------

#### button

With text and/or image, calls a configurable command when clicked.
Example:

`button .b -text Hello! -command {puts "hello, world"}`

#### canvas

Scrollable graphic surface for line, rectangle, polygon, oval, and text
items, as well as bitmaps and photo images and whole embedded windows.
See for example \"A tiny drawing program\" below. Example:

`pack [canvas .c -background white]`\
`.c create line 50 50 100 100 150 50 -fill red -width 3`\
`.c create text 100 50 -text Example`

**Pan a canvas** (scroll it inside its window with middle mouse-button
held down) by inheriting the text widget bindings:

` bind .c <2> [bind Text <2>]`\
` bind .c ``<B2-Motion>`{=html}` [bind Text ``<B2-Motion>`{=html}`]`

#### entry

One-line editable text field, horizontally scrollable (see example
above). You can specify a validation function to constrain what is
entered. Example:

`entry .e -width 20 -textvariable myVar`\
`set myVar "this text appears in the entry"`

#### frame

Container for several widgets, often used with *pack*, or for wrapping
\"megawidgets\"

#### label

One- or multiline field for text display, can be tied to a text variable
to update when that variable changes. Linebreaks are specified by \\n in
the text to be displayed.

#### labelframe

A container similar to a **frame**, decorated with a thin rectangle
around, and a label at top-left position. Example (a tiny radio band
selector):

`pack [labelframe .lf -text Band]`\
`pack [radiobutton .lf.am -text AM -variable band -value AM]`\
`pack [radiobutton .lf.fm -text FM -variable band -value FM]`\
`set band AM`

![](Labelframe_radiobuttons.jpg "Labelframe_radiobuttons.jpg")

#### listbox

Multiline display of a list, scrollable. Single or multiple items can be
selected with the mouse.

#### menu

To add a menu to a GUI application, take steps of three kinds:

-   Create the toplevel horizontal menu (needed only once):

`. configure -menu [menu .m]`

-   For each item in the top menu, create a cascaded submenu, e.g.

`.m add cascade -label File -menu [menu .m.mFile]`

-   For each entry in a submenu, add it like this:

`.m.mFile add command -label Open -command {openFile ...}`\
`.m.mFile add separator`

As these commands are a bit verbose, one can wrap them into a little
helper:

`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}`\
`}`

Demo example - now menu items can be created in a much clearer way:

`. configure -menu [menu .m]`\
`m+ File Open {.t insert end "opened\n"}`\
`m+ File Save {.t insert end "saved\n"}`\
`m+ File -----`\
`m+ File Exit exit`\
`m+ Edit Cut ...`\
`pack [text .t -wrap word] -fill both -expand 1`

#### radiobutton

A button with a selector field which can be on or off, and a label.
Clicking the selector field with the mouse changes the value of an
associated global variable. Typically, multiple radiobuttons are tied to
the same variable. For examples, see **labelframe** above.

#### scrollbar

Horizontal or vertical scrollbars (vertical being the default, for
horizontal specify: -orientation horizontal, or -ori hori if you like it
short) can be tied to canvas, entry, listbox or text widgets. The
interaction between a scrollbar and its scrolled widget goes with
callbacks, in which one notifies the other:

-   scrollbar to widget: *xview* or *yview* method
-   widget to scrollbar: *set* method

Arguments to these methods will be automatically added when the
callbacks are invoked.

For example, here\'s how to connect a text widget with a vertical
scrollbar:

`pack [scrollbar .y -command ".t yview"] -side right -fill y`\
`pack [text .t -wrap word -yscrollc ".y set"] \`\
`     -side right -fill both -expand 1`

With most widgets, scrollbars adjust automatically to the widget\'s
contents. For canvas widgets, you need to update the scrollregion after
adding new items. most simply like this:

`$canvas configure -scrollregion [$canvas bbox all]`

#### text

Scrollable editable multiline text with many formatting options. Can
also contain images and embedded widgets. The default wrapping setting
is \"none\", so you might need a horizontal scrollbar to see all of long
lines. In many cases it\'s more user-friendly to configure a text widget
as *-wrap word* - then you only need a vertical scrollbar at most.

Positions in a text widget are specified as *line.column*, where line
starts from 1, and column from 0, so 1.0 is the very first character in
a text widget. Example how to delete all contents:

`$t delete 1.0 end`

For highlighting part of the contents, you can define *tags* and assign
them to subsequences:

`$t tag configure ul -underline 1`\
`$t insert end "The next word is " {} underlined ul ", the rest is not."`

#### toplevel

Standalone frame window, mostly with decorations (title bar, buttons)
from the window manager. When you start Tk, you receive an initially
empty toplevel named \".\" (one dot). If you want more toplevels, create
them like this:

`toplevel .mySecondWindow`

Such toplevels are logically children of \".\". To assign a nice title
to a toplevel, use

`wm title $toplevel "This is the title"`

You can also control the geometry (size and position) of a toplevel with

`wm geometry $toplevel ${width}x$height+$x+$y`

------------------------------------------------------------------------

### Geometry managers

------------------------------------------------------------------------

The purpose of geometry managers is to compute the required height,
width, and location of widgets, and map them on screen. Besides *grid*,
*pack* and *place*, the *canvas* and *text* widgets can also manage
embedded widgets.

Calls to geometry managers always start with the manager\'s name, then
(mostly) one or more widget names, then any number of *-name value*
options

#### grid

This geometry manager is best suited for tabular window layout
consisting of rows and columns. Example, to put three widgets in a
horizontal row:

`grid .1 .2 .3 -sticky news`

The *-sticky* option indicates what side of its box the widget should
stick to, in compass direction; \"news\" is north-east-west-south\",
i.e. all four sides.

Here\'s a minimal solution to display a table (list of lists) in a grid
of labels:

![](grid_table.jpg "grid_table.jpg")

`package require Tk`\
`proc table {w content args} {`\
`    frame $w -bg black`\
`    set r 0`\
`    foreach row $content {`\
`        set fields {}`\
`        set c 0`\
`        foreach col $row {`\
`            lappend fields [label $w.$r/$c -text $col]`\
`            incr c`\
`        }`\
`        eval grid $fields -sticky news -padx 1 -pady 1`\
`        incr r`\
`    }`\
`    set w`\
`}`

`#--- Test:`\
`table .t {`\
`   {Row Head1 Head2}`\
`   {1   foo   42}`\
`   {2   bar   1234}`\
`   {3   grill testing}`\
`}`\
`pack .t`

`#--- Changing the contents, given row and column number:`\
`after 2000 .t.3/2 config -text Coucou`

#### pack

This used to be the workhorse manager, but in recent years has been less
popular than **grid**. Anyway, it is still good for cases where you have
widgets aligned in only one direction (horizontally or vertically). For
more complex layouts, one used to insert intermediate frames, but grid
makes such jobs just easier. Example:

`pack .x -fill both -expand 1 -side left`

#### place

This geometry manager is not often used, mostly for special
applications, like when you want to highlight the current tab of a tab
notebook. It allows pixel-precise placement of widgets, but is less
dynamic in reaction to resizing of the toplevel or inner widgets.

### Dialogs

Dialogs are toplevels that are to tell a message, or answer a question.
You don\'t have to assign a widget path name to them. Just call them as
functions and evaluate the result (often \"\" if the dialog was
canceled).

#### tk_getOpenFile

A file selector dialog (limited to existing files). Returns the selected
file with path name, or \"\" if canceled.

#### tk_getSaveFile

A file selector dialog, which also allows specification of a not
existing file. Returns the selected file with path name, or \"\" if
canceled.

#### tk_messageBox

A simple dialog that displays a string and can be closed with an \"OK\"
button. Example:

`tk_messageBox -message "hello, world!"`

#### tk_chooseColor

Displays a dialog for color selection. The returned value is the
selected color in one of the representations conformant to Tcl\'s
comprehension of such information; on Microsoft Windows systems this
might constitute a hexadecimal string in the format "#RRGGBB". Upon
abortion of the process, the empty string is instead delivered. The
dialog may be configured to preselect a certain default color via the
"-initialcolor" option, a subordination into a parent widget with
"-parent", and a title caption through "-title".

` tk_chooseColor -initialcolor #FF0000 -parent . -title "What tincture do you wish?"`

#### Custom dialogs

Besides the prefabricated dialogs that come with Tk, it\'s also not too
hard to build custom ones. As a very simple example, here\'s a \"value
dialog\" that prompts the user for to type in a value:

![](ValueDialog.jpg "ValueDialog.jpg")

`proc value_dialog {string} {`\
`   set w [toplevel .[clock seconds]]`\
`   wm resizable $w 0 0`\
`   wm title $w "Value request"`\
`   label  $w.l -text $string`\
`   entry  $w.e -textvar $w -bg white`\
`   bind $w.e ``<Return>`{=html}` {set done 1}`\
`   button $w.ok     -text OK     -command {set done 1}`\
`   button $w.c      -text Clear  -command "set $w {}"`\
`   button $w.cancel -text Cancel -command "set $w {}; set done 1"`\
`   grid $w.l  -    -        -sticky news`\
`   grid $w.e  -    -        -sticky news`\
`   grid $w.ok $w.c $w.cancel`\
`   vwait done`\
`   destroy $w`\
`   set ::$w`\
`}`

Test:

`set test [value_dialog "Give me a value please:"]`\
`puts test:$test`\
`pack [ label .l -text "Value: '$test' " ]`

For a more elaborate example, here is a record editor dialog (multiple
fields, each with a label and entry (or text for multi-line input)):

`proc editRecord {title headers fields} {`\
`    set oldfocus [focus]`\
`    set w [toplevel .[clock clicks]]`\
`    wm resizable $w 1 0`\
`    wm title $w $title`\
`    set n 0`\
`    foreach h $headers f $fields {`\
`        if ![regexp {(.+)([=+])} $h -> hdr type] {set hdr $h; set type ""}`\
`        label $w.h$n -text $hdr -anchor ne`\
`        switch -- $type {`\
`            = {label $w.e$n -width [string length $f] -text $f -anchor w -bg white}`\
`            + {[text $w.e$n -width 20 -height 6] insert end $f}`\
`            default {[entry $w.e$n -width [string length $f]] insert end $f}`\
`        }`\
`        grid $w.h$n $w.e$n -sticky news`\
`        incr n`\
`    }`\
`    button $w.ok -text OK -width 5 -command [list set $w 1]`\
`    button $w.cancel -text Cancel -command [list set $w 0]`\
`    grid $w.ok $w.cancel -pady 5`\
`    grid columnconfigure $w 1 -weight 1`\
`    vwait ::$w`\
`    if [set ::$w] { #-- collect the current entry contents`\
`        set n 0`\
`        foreach h $headers f $fields {`\
`            regexp {([^=+].+)([=+]?)} $h -> hdr type`\
`            switch -- $type {`\
`                "" {lappend res [$w.e$n get]}`\
`                =  {lappend res [$w.e$n cget -text]}`\
`                +  {lappend res [$w.e$n get 1.0 end]}`\
`            }`\
`            incr n`\
`        }`\
`    } else {set res {}}`\
`    destroy $w`\
`    unset ::$w ;#-- clean up the vwait variable`\
`    focus $oldfocus`\
`    return $res`\
`}`

Quick test:

`editRecord Test {foo= bar grill+} {one two three}`

### Megawidgets made easy

The term \"megawidgets\" is popular for compound widgets that in
themselves contain other widgets, even though they will hardly number a
million (what the prefix *Mega-* suggests), more often the child
widgets\' number will not exceed ten.

To create a megawidget, one needs one proc with the same signature as Tk
widget creation commands. This proc will, when called, create another
proc named after the widget, and dispatch methods either to specific
handlers, or the generic widget command created by Tk.

#### A little notebook

Plain Tk does not contain a \"notebook\" widget, with labeled tabs on
top that raise one of the \"pages\", but it\'s easy to make one. This
example demonstrates how the tabs are implemented as buttons in a frame,
and how the original Tk command named like the frame is \"overloaded\"
to accept the additional *add* and *raise* methods:

`proc notebook {w args} {`\
`   frame $w`\
`   pack [frame $w.top] -side top -fill x -anchor w`\
`   rename $w _$w`\
`   proc $w {cmd args} { #-- overloaded frame command`\
`       set w [lindex [info level 0] 0]`\
`       switch -- $cmd {`\
`           add     {notebook'add   $w $args}`\
`           raise   {notebook'raise $w $args}`\
`           default {eval [linsert $args 0 _$w $cmd]}`\
`       }`\
`   }`\
`   return $w`\
`}`

`proc notebook'add {w title} {`\
`   set btn [button $w.top.b$title -text $title -command [list $w raise $title]]`\
`   pack $btn -side left -ipadx 5`\
`   set f [frame $w.f$title -relief raised -borderwidth 2]`\
`   pack $f -fill both -expand 1`\
`   $btn invoke`\
`   bind $btn <3> "destroy {$btn}; destroy {$f}" ;# (1)`\
`   return $f`\
`}`

`proc notebook'raise {w title} {`\
`   foreach i [winfo children $w.top] {$i config -borderwidth 0}`\
`   $w.top.b$title config -borderwidth 1`\
`   set frame $w.f$title`\
`   foreach i [winfo children $w] {`\
`       if {![string match *top $i] && $i ne $frame} {pack forget $i}`\
`   }`\
`   pack $frame -fill both -expand 1`\
`}`

Test and demo code:

`package require Tk`\
`pack [notebook .n] -fill both -expand 1`\
`set p1 [.n add Text]`\
`pack   [text $p1.t -wrap word] -fill both -expand 1`\
`set p2 [.n add Canvas]`\
`pack   [canvas $p2.c -bg yellow] -fill both -expand 1`\
`set p3 [.n add Options]`\
`pack   [button $p3.1 -text Console -command {console show}]`\
`.n raise Text`\
`wm geometry . 400x300`

### Binding events

Events within Tcl/Tk include actions performed by the user, such as
pressing a key or clicking the mouse. To react to mouse and keyboard
activity, the bind command is used. As shown in the calculator example:

``` tcl
 pack [entry .e -textvar e -width 50]
 bind .e <Return> {
```

The `bind` keyword operates on `.e` and associates the event related to
the `<return>` event. The following bracket indicates a start of a set
of procedures which are executed when the event is performed.

### BWidget

BWidget is an extension to Tk written in pure Tcl (therefore it can even
run on Windows Mobile-driven cell phones). It offers mega-widgets (all
class names starting with Uppercase) like

-   ComboBox
-   NoteBook
-   Tree

!`ifile01.jpg`

*Screenshot of a NoteBook and a Tree, on a PocketPC under Windows/CE*

#### Tree examples

Here is a \"hello world\" example of a Tree widget (this is a complete
script). The root node is constantly called *root*, for the others you
have to make up names:

`package require BWidget`\
`pack [Tree .t]`\
`.t insert end root n1  -text hello`\
`.t insert end root n2  -text world`\
`.t insert end n2   n21 -text (fr:monde)`\
`.t insert end n2   n22 -text (de:Welt)`

The famous typewriter test sentence represented as a syntax tree:

`package require BWidget`\
`pack [Tree .t -height 16] -fill both -expand 1`\
`foreach {from to text} {`\
`   root S S`\
`   S   np1  NP`\
`   S   vp   VP`\
`   np1 det1 Det:The`\
`   np1 ap1  AP`\
`   ap1 adj1 Adj:quick`\
`   ap1 adj2 Adj:brown`\
`   ap1 n1   N:fox`\
`   vp  v    V:jumps`\
`   vp  pp   PP`\
`   pp  prep Prep:over`\
`   pp  np2  NP`\
`   np2 det2 Det:the`\
`   np2 ap2  AP`\
`   ap2 adj3 Adj:lazy`\
`   ap2 n2   N:dog`\
`   `\
`} {.t insert end $from $to -text $text}`\
`.t opentree S`

### Tk resources

#### Colors

Colors in Tk can be specified in three ways:

-   a symbolic name, like: red green blue yellow magenta cyan
-   a hex string preceded by a #: #RGB, #RRGGBB, #RRRRGGGGBBBB
-   a list of three non-negative integers

The last form is only returned by commands. To specify a color to a
command, you\'ll have to hex-format it. For instance, white could be
described as #FFFFFF.

To turn a symbolic name into its RGB components:

`winfo rgb . $colorname`

Here is the list of defined color names (as from X11\'s rgb.txt):

`set COLORS { snow {ghost white} {white smoke} gainsboro {floral white}`\
`   {old lace} linen {antique white} {papaya whip} {blanched almond}`\
`   bisque {peach puff} {navajo white} moccasin cornsilk ivory {lemon`\
`   chiffon} seashell honeydew {mint cream} azure {alice blue}`\
`   lavender {lavender blush} {misty rose} white black {dark slate`\
`   gray} {dim gray} {slate gray} {light slate gray} gray {light grey}`\
`   {midnight blue} navy {cornflower blue} {dark slate blue} {slate`\
`   blue} {medium slate blue} {light slate blue} {medium blue} {royal`\
`   blue} blue {dodger blue} {deep sky blue} {sky blue} {light sky`\
`   blue} {steel blue} {light steel blue} {light blue} {powder blue}`\
`   {pale turquoise} {dark turquoise} {medium turquoise} turquoise`\
`   cyan {light cyan} {cadet blue} {medium aquamarine} aquamarine`\
`   {dark green} {dark olive green} {dark sea green} {sea green}`\
`   {medium sea green} {light sea green} {pale green} {spring green}`\
`   {lawn green} green chartreuse {medium spring green} {green yellow}`\
`   {lime green} {yellow green} {forest green} {olive drab} {dark`\
`   khaki} khaki {pale goldenrod} {light goldenrod yellow} {light`\
`   yellow} yellow gold {light goldenrod} goldenrod {dark goldenrod}`\
`   {rosy brown} {indian red} {saddle brown} sienna peru burlywood`\
`   beige wheat {sandy brown} tan chocolate firebrick brown {dark`\
`   salmon} salmon {light salmon} orange {dark orange} coral {light`\
`   coral} tomato {orange red} red {hot pink} {deep pink} pink {light`\
`   pink} {pale violet red} maroon {medium violet red} {violet red}`\
`   magenta violet plum orchid {medium orchid} {dark orchid} {dark`\
`   violet} {blue violet} purple {medium purple} thistle snow2 snow3`\
`   snow4 seashell2 seashell3 seashell4 AntiqueWhite1 AntiqueWhite2`\
`   AntiqueWhite3 AntiqueWhite4 bisque2 bisque3 bisque4 PeachPuff2`\
`   PeachPuff3 PeachPuff4 NavajoWhite2 NavajoWhite3 NavajoWhite4`\
`   LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk2 cornsilk3`\
`   cornsilk4 ivory2 ivory3 ivory4 honeydew2 honeydew3 honeydew4`\
`   LavenderBlush2 LavenderBlush3 LavenderBlush4 MistyRose2 MistyRose3`\
`   MistyRose4 azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3`\
`   SlateBlue4 RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue2 blue4`\
`   DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2`\
`   SteelBlue3 SteelBlue4 DeepSkyBlue2 DeepSkyBlue3 DeepSkyBlue4`\
`   SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1 LightSkyBlue2`\
`   LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3`\
`   SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3`\
`   LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4`\
`   LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2`\
`   PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3`\
`   CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan2 cyan3`\
`   cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 DarkSlateGray4`\
`   aquamarine2 aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3`\
`   DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 PaleGreen1 PaleGreen2`\
`   PaleGreen3 PaleGreen4 SpringGreen2 SpringGreen3 SpringGreen4`\
`   green2 green3 green4 chartreuse2 chartreuse3 chartreuse4`\
`   OliveDrab1 OliveDrab2 OliveDrab4 DarkOliveGreen1 DarkOliveGreen2`\
`   DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4`\
`   LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4`\
`   LightYellow2 LightYellow3 LightYellow4 yellow2 yellow3 yellow4`\
`   gold2 gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4`\
`   DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4`\
`   RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 IndianRed2`\
`   IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4 burlywood1`\
`   burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3 wheat4 tan1`\
`   tan2 tan4 chocolate1 chocolate2 chocolate3 firebrick1 firebrick2`\
`   firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 salmon2`\
`   salmon3 salmon4 LightSalmon2 LightSalmon3 LightSalmon4 orange2`\
`   orange3 orange4 DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4`\
`   coral1 coral2 coral3 coral4 tomato2 tomato3 tomato4 OrangeRed2`\
`   OrangeRed3 OrangeRed4 red2 red3 red4 DeepPink2 DeepPink3 DeepPink4`\
`   HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4`\
`   LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1`\
`   PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 maroon2`\
`   maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 VioletRed4`\
`   magenta2 magenta3 magenta4 orchid1 orchid2 orchid3 orchid4 plum1`\
`   plum2 plum3 plum4 MediumOrchid1 MediumOrchid2 MediumOrchid3`\
`   MediumOrchid4 DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4`\
`   purple1 purple2 purple3 purple4 MediumPurple1 MediumPurple2`\
`   MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 thistle4`\
`   gray1 gray2 gray3 gray4 gray5 gray6 gray7 gray8 gray9 gray10`\
`   gray11 gray12 gray13 gray14 gray15 gray16 gray17 gray18 gray19`\
`   gray20 gray21 gray22 gray23 gray24 gray25 gray26 gray27 gray28`\
`   gray29 gray30 gray31 gray32 gray33 gray34 gray35 gray36 gray37`\
`   gray38 gray39 gray40 gray42 gray43 gray44 gray45 gray46 gray47`\
`   gray48 gray49 gray50 gray51 gray52 gray53 gray54 gray55 gray56`\
`   gray57 gray58 gray59 gray60 gray61 gray62 gray63 gray64 gray65`\
`   gray66 gray67 gray68 gray69 gray70 gray71 gray72 gray73 gray74`\
`   gray75 gray76 gray77 gray78 gray79 gray80 gray81 gray82 gray83`\
`   gray84 gray85 gray86 gray87 gray88 gray89 gray90 gray91 gray92`\
`   gray93 gray94 gray95 gray97 gray98 gray99`\
`}`

In addition, the following are defined on Windows:

`set WINDOWSCOLORS {`\
`   SystemButtonFace SystemButtonText SystemDisabledText SystemHighlight`\
`   SystemHightlightText SystemMenu SystemMenuText SystemScrollbar`\
`   SystemWindow SystemWindowFrame SystemWindowText`\
`}`

#### Cursors

For every widget, you can specify how the mouse cursor should look when
over it. Here\'s the list of defined cursor names:

`set cursors {`\
`   X_cursor arrow based_arrow_down based_arrow_up boat bogosity`\
`   bottom_left_corner bottom_right_corner bottom_side bottom_tee`\
`   box_spiral center_ptr circle clock coffee_mug cross cross_reverse`\
`   crosshair diamond_cross dot dotbox double_arrow draft_large draft_small`\
`   draped_box exchange fleur gobbler gumby hand1 hand2 heart icon`\
`   iron_cross left_ptr left_side left_tee leftbutton ll_angle lr_angle`\
`   man middlebutton mouse pencil pirate plus question_arrow right_ptr`\
`   right_side right_tee rightbutton rtl_logo sailboat sb_down_arrow`\
`   sb_h_double_arrow sb_left_arrow sb_right_arrow sb_up_arrow`\
`   sb_v_double_arrow shuttle sizing spider spraycan star target tcross`\
`   top_left_arrow top_left_corner top_right_corner top_side top_tee `\
`   trek ul_angle umbrella ur_angle watch xterm`\
`}`

A little tool that presents the cursor names, and shows each cursor
shape when mousing over:

`set ncols 4`\
`for {set i 0} {$i<$ncols} {incr i} {`\
`   lappend cols col$i`\
`}`\
`set nmax [expr {int([llength $cursors]*1./$ncols)}]`\
`foreach col $cols {`\
`   set $col [lrange $cursors 0 $nmax]`\
`   set cursors [lrange $cursors [expr $nmax+1] end]`\
`}`\
`label .top -text "Move the cursor over a name to see how it looks" \`\
`   -relief ridge`\
`grid .top -columnspan $ncols -sticky news -ipady 2`\
`for {set i 0} {$i<[llength $col0]} {incr i} {`\
`   set row {}`\
`   foreach col $cols {`\
`       set name [lindex [set $col] $i]`\
`       if {$name eq ""} break`\
`       lappend row .l$name`\
`       label .l$name -text $name -anchor w`\
`       bind .l$name ``<Enter>`{=html}` [list %W config -cursor $name]`\
`   }`\
`   eval grid $row -sticky we`\
`}`

#### Fonts

Fonts are provided by the windowing system. Which are available depends
on the local installation. Find out which fonts are available with

`font families`

The typical description of a font is a list of up to three elements:

`family size ?style?`

Example:

`set f ``{{Bitstream Cyberbit} 10 bold}
Family is a name like Courier, Helvetica, Times, ... Best pick one of the names delivered by ''font families'', though there may be some mappings like "Helvetica" -> "Arial"

Size is point size (a typographer's point is 1/72th of an inch) if positive, or pixel size if negative. Normal display fonts often have a size of 9 or 10.

Style can be a list of zero or more of bold, italic, underlined, ...

==== Images: photos and bitmaps ====

Tk allows simple yet powerful operations on images. These come in two varieties: bitmaps and photos. Bitmaps are rather limited in functionality, they can be specified in XBM format, and rendered in configurable colors.

Photos have much more possibilities - you can load and save them in different file formats (Tk itself supports PPM and GIF - for others, use the Img extension), copy them with many options, like scaling/subsampling or mirroring, and get or set the color of single pixels.

Setting can also do rectangular regions in one go, as the following example shall demonstrate that creates a photo image of a tricolore flag (three even-spaced vertical bands - like France, Italy, Belgium, Ireland and many more). The default is France.
You can specify the width, the height will be 2/3 of that.
The procedure returns the image name - just save it in -format GIF if you want:

 proc tricolore {w {colors {blue white red}}`{=mediawiki}`} {`\
`   set im [image create photo]`\
`   set fromx 0`\
`   set dx [expr $w/3]`\
`   set tox $dx`\
`   set toy [expr $w*2/3]`\
`   foreach color $colors {`\
`       $im put $color -to $fromx 0 $tox $toy`\
`       incr fromx $dx; incr tox $dx`\
`   }`\
`   set im`\
`}`

`# Test - display flag on canvas:`\
`pack [canvas .c -width 200 -height 200 -background grey]`\
`.c create image 100 100 -image [tricolore 150]`

`# Test - save image of flag to file:`\
`[tricolore 300] write tric.gif -format gif`

### Debugging Tk programs

A Tk program under development can be very rapidly debugged by adding
such bindings:

`bind . ``<F1>`{=html}` {console show}`

This works only on Windows and Macintosh (pre-OS-X) and brings up a
console in which you can interact with the Tcl interpreter, inspect or
modify global variables, configure widgets, etc.

`bind . ``<Escape>`{=html}` {eval [list exec wish $argv0] $argv &; exit}`

This starts a new instance of the current program (assuming you edited a
source file and saved it to disk), and then terminates the current
instance.

For short debugging output, one can also use the window\'s title bar.
For example, to display the current mouse coordinates when it moves:

`bind . ``<Motion>`{=html}` {wm title . %X/%Y}`

### Other languages

Other programming languages have modules that interface and use Tcl/Tk:

-   In R (programming language), there\'s a tcltk library, invoked with
    the command **library(tcltk)**
-   In Python, there\'s a tkinter module, invoked with **import
    tkinter** or **from tkinter import \***
-   Common Lisp can communicate with Tcl/Tk via several externally
    available libraries, including **CL-TK** and **LTK**


# 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

This 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

This 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

image:TkPiechart.jpg

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

image:3DBarchart.jpg

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

![](Tcl_calculator.jpg "Tcl_calculator.jpg")

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>`{=html}` =`\
`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

The 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.

![](Sliderule_Tk.jpg "Sliderule_Tk.jpg")

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>`{=html}/`<Shift-Right>`{=html} 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>`{=html}/`<Right>`{=html}.

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>`{=html}` {.c coords mark %x 0 %x 170; set info [values .c]}`\
`   bind .c <1> {set x %x}`\
`   bind .c ``<B1-Motion>`{=html}` {%W move slide [expr {%x-$x}] 0; set x %x}`\
`   bind . ``<Shift-Left>`{=html}`  {.c move slide -1 0; set info [values .c]}`\
`   bind . ``<Shift-Right>`{=html}` {.c move slide  1 0; set info [values .c]}`\
`   bind . ``<Left>`{=html}`  {.c move mark -1 0; set info [values .c]}`\
`   bind . ``<Right>`{=html}` {.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>`{=html}` {exec wish $argv0 &; exit}`

### A minimal doodler

Here 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>`{=html}` {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>`{=html}` {%W delete all}`

![](Doodler.jpg "Doodler.jpg")

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>`{=html}` {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>`{=html}` {%W delete all}`

### A tiny drawing program

Here 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.

![](Tinydraw.jpg "Tinydraw.jpg")

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>`{=html}` {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>`{=html}` {`\
`   package require Img`\
`   set img [image create photo -data .c]`\
`   set name [tk_getSaveFile -filetypes ``{{GIFF .gif} {"All files" *}}`{=mediawiki}`\`\
`       -defaultextension .gif]`\
`   if {$name ne ""} {$img write $name; wm title . $name}`\
`}`

`#-- This is an always useful helper in development:`\
`bind . ``<Escape>`{=html}` {exec wish $argv0 &; exit}`

### A minimal editor

Here\'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>`{=html}` {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>`{=html}` {loadText .t [tk_getOpenFile]}`\
`bind . ``<F3>`{=html}` {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

Some 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

This 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>`{=html}`} {bind . $e {slide'show 1}}`\
`  foreach e {<3> ``<Left>`{=html}`} {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>`{=html}` {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

Yet 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

![](Timeliner.jpg "Timeliner.jpg")

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>`{=html}` {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

![](funplot.jpg "funplot.jpg")

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>`{=html} 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>`{=html}` {displayXY .info %x %y}`\
`   frame  .f`\
`     label  .f.1 -text "f(x) = "`\
`     entry  .f.f -textvar ::function -width 40`\
`       bind .f.f ``<Return>`{=html}` {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>`{=html}`               {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

In 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?\"

![](funimj.jpg "funimj.jpg")

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>`{=html} 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>`{=html}` [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>`{=html}` {exec wish $argv0 &; exit} ;# dev helper`\
`bind . ? {console show} ;# dev helper, Win/Mac only`

### TkPhotoLab

The 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.

![](TkPhotoLab.jpg "TkPhotoLab.jpg")

*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}}`{=mediawiki}\
`   label .) -text ) -font {Courier 32}`\
`   button .c -text C -command {setFilter .t ``{{0 0 0} {0 0 0} {0 0 0}}`{=mediawiki}`}`\
`   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}}`{=mediawiki}`}`\
`   m+ Filter ---`\
`   m+ Filter Blur0  {setFilter .t ``{{1 1 1} {1 0 1} {1 1 1}}`{=mediawiki}`}`\
`   m+ Filter Blur1  {setFilter .t ``{{1 1 1} {1 1 1} {1 1 1}}`{=mediawiki}`}`\
`   m+ Filter Gauss2 {setFilter .t ``{{1 2 1} {2 4 2} {1 2 1}}`{=mediawiki}`}`\
`   m+ Filter ---`\
`   m+ Filter Laplace5 {setFilter .t ``{{0 -1 0} {-1 5 -1} {0 -1 0}}`{=mediawiki}`}`\
`   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}}`{=mediawiki}`}`\
`   m+ Filter ---`\
`   m+ Filter Emboss   {setFilter .t ``{{2 0 0} {0 -1 0} {0 0 -1}}`{=mediawiki}`}`\
`   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}}`{=mediawiki}`}`\
`   m+ Filter SobelV   {setFilter .t ``{{1 0 -1} {2 0 -2} {1 0 -1}}`{=mediawiki}`}`

`   bind . ``<Escape>`{=html}` {exec wish $argv0 &; exit}`\
`   bind . ``<F1>`{=html}` {console show}`\
`   loadImg aaa.jpg`\
`}`