Now Reading
Tcl Programming/Tk examples – Wikibooks, open books for an open world

Tcl Programming/Tk examples – Wikibooks, open books for an open world

2023-04-20 17:25:15

The next examples initially appeared within the Tcler’s Wiki . They’re all within the public area – no rights reserved.

A humorous cookbook[edit | edit source]

This humorous little program produces random cooking recipes. Small as it’s, it could actually produce 900 totally different recipes, although they won’t be to everyone’s style… The fundamental thought is to choose an arbitrary component from an inventory, which is well completed in Tcl with the next:

proc ? L {lindex $L [expr {int(rand()*[llength $L])}]}

That is used a number of instances in:

proc recipe {} {
  set a {
    {3 eggs} {an apple} {a pound of garlic}
    {a pumpkin} {20 marshmallows}
  set b {
    {Minimize in small items} {Dissolve in lemonade}
    {Bury within the floor for 3 months}
    {Bake at 300 levels} {Prepare dinner till 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].
  Prime with [? $c].
  Serve with [? $d]."

And as fashionable packages at all times want a GUI, here’s a minimal one which seems while you supply this file at high degree, and exhibits a brand new recipe each time you click on on it:

if {[file tail [info script]]==[file tail $argv0]} {
  package deal require Tk
  pack [text .t -width 40 -height 5]
  bind .t <1> {showRecipe %W; break}
  proc showRecipe w {
    $w delete 1.0 finish
    $w insert finish [recipe]
  showRecipe .t

Take pleasure in!

A little bit A/D clock[edit | edit source]

This can be a clock that exhibits time both analog or digital – simply click on on it to toggle.

#!/usr/bin/env tclsh
package deal require Tk

proc each {ms physique} {eval $physique; after $ms [info level 0]}

proc drawhands w {
    $w delete fingers
    set secSinceMidnight [expr {[clock sec]-[clock scan 00:00:00]}]
    foreach divisor {60 3600 43200} size {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 fingers
proc toggle {w1 w2} {
    if [winfo ismapped $w2] {
        foreach {w2 w1} [list $w1 $w2] break ;# swap
    pack overlook $w1
    pack $w2
#-- Creating the analog clock:
canvas .analog -width 100 -height 100 -bg white
each 1000 {drawhands .analog}
pack .analog

#-- Creating the digital clock:
label .digital -textvar ::time -font {Courier 24}
each 1000 {set ::time [clock format [clock sec] -format %H:%M:%S]}

bind . <1> {toggle .analog .digital}

A little bit pie chart[edit | edit source]

Arc components of a canvas are by default rendered as pie slices (a part of the circumference of a circle, linked by radius traces to the middle. Therefore it s relatively simple to provide a pie chart. The next code is a little more advanced, because it additionally determines positions for the labels of the pies:

proc piechart {w x y width top information} {
   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 merchandise $information {set sum [expr {$sum + [lindex $item 1]}]}
   set begin 270
   foreach merchandise $information {
       foreach {title n colour} $merchandise break
       set extent [expr {$n*360./$sum}]
       $w create arc $coords -start $begin -extent $extent -fill $colour
       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 textual content $tx $ty -text $title:$n  -tag txt
       set begin [expr $start+$extent]
   $w increase txt


pack [canvas .c -bg white]
piechart .c 50 50 150 150 {
   {SPD  199 purple}
   {CDU  178 grey}
   {CSU   23 blue}
   {FDP   60 yellow}
   {Grüne 58 inexperienced}
   {Linke 55 purple}

A little bit 3D bar chart[edit | edit source]

The next script shows a bar chart on a canvas, with pseudo-Three-dimensional bars – a rectangle in entrance as specified, embellished with two polygons – one for the highest, one for the aspect:}

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 extra plastic look, the fill colour of the polygons is decreased in brightness (“dimmed”):

proc dim {colour issue} {
  foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
     set $i [expr int(255.*$n/$d*$factor)]
  format #%02xpercent02xpercent02x $r $g $b

Draw a easy scale for the y axis, and return the scaling issue:

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
  whereas {$label>=$min} {
     $w create textual content $x0 $y -text $label -anchor w
     set y [expr {$y+$stepy}]
     set label [expr {$label-$step}]
  expr {$dy/double($max)}

An attention-grabbing sub-challenge was to spherical numbers very roughly, to 1 or maximally 2 important digits – by default rounding up, add “-” to spherical down:

proc roughly {n {sgn +}} {
  regexp {(.+)e([+-])0*(.+)} [format %e $n] -> mant signal 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 right here is my little bar chart generator. Given a canvas pathname, a bounding rectangle, and the info to show (an inventory of {title worth colour} triples), it figures out the geometry. A grey “floor aircraft” is drawn first. Observe how detrimental values are tagged with “d”(eficit), so that they appear like they “drop by way of the aircraft”.

proc bars {w x0 y0 x1 y1 information} {
   set vals 0
   foreach bar $information {
      lappend vals [lindex $bar 1]
   set high [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 $information {
      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 textual content [expr {$x+12}] [expr {$y-12}] -text $val
      $w create textual content [expr {$x+12}] [expr {$y1a+2}] -text $txt -anchor n
      incr x $dx
   $w decrease d

Typically helpful helper capabilities:

proc max listing {
   set res [lindex $list 0]
   foreach e [lrange $list 1 end] {
      if {$e>$res} {set res $e}
   set res
proc min listing {
   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 entire thing (see screenshot):

pack [canvas .c -width 240 -height 280]
bars .c 10 20 240 230 {
  {purple 765 purple}
  {inexperienced 234 inexperienced}
  {blue 345 blue}
  {yel-nlow 321 yellow}
  {ma-ngenta 567 magenta}
  {cyan -123 cyan}
  {white 400 white}
.c create textual content 120 10 -anchor nw -font {Helvetica 18} -text "Bar ChartnDemo"

A little bit calculator[edit | edit source]

Here’s a small calculator in Tcl/Tk. Along with the buttons on display, you should utilize any of expr’s different functionalities through keyboard enter.

package deal require Tk
wm title . Calculator
grid [entry .e -textvar e -just right] -columnspan 5
bind .e <Return> =
set n 0
foreach row {
   {7 8 9 + -}
   {4 5 6 * /}
   {1 2 3 ( )}
   {C 0 . =  }
} {
   foreach key $row {
       change -- $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 final key (=) double broad
proc = {} {
   regsub { =.+} $::e "" ::e ;# possibly clear earlier end result
   if [catch {set ::res [expr [string map {/ *1.0/} $::e]]}] {
       .e config -fg purple
   append ::e = $::res 
   .e xview finish
   set ::clear 1
proc hit {key} {
   if $::clear {
       set ::e ""
       if ![regexp {[0-9().]} $key] {set ::e $::res}
       .e config -fg black
       .e icursor finish
       set ::clear 0
   .e insert finish $key
set clear 0
focus .e           ;# enable keyboard enter
wm resizable . 0 0

And, as Cameron Laird famous, this thingy is even programmable: enter for instance

[proc fac x {expr {$x<2? 1: $x*[fac [incr x -1]]}}]

into the entry, disregard warnings; now you are able to do

[fac 10]

and obtain [fac 10] = 3628800.0 as end result…

A little bit slide rule[edit | edit source]

The slide rule was an analog, mechanical system for approximate engineering computing, made out of date by the pocket calculator since concerning the 1970-80s. The fundamental precept is that multiplication is finished by including logarithms, therefore a lot of the scales are logarithmic, with uneven increments.

This enjoyable mission recreates a slide rule (roughly an Aristo-Rietz Nr. 89 with 7 scales – high-notch ones had as much as 24) with a white “physique” and a beige “slide” which you’ll be able to transfer left or proper with mouse button 1 clicked, or in pixel increment with the <Shift-Left>/<Shift-Proper> cursor keys. Lastly, the blue line represents the “mark” (how is that appropriately referred to as? “runner”? “slider”?) which you’ll be able to transfer with the mouse over the entire thing to learn a price. Tremendous actions with <Left>/<Proper>.

Attributable to rounding errors (integer pixels), this plaything is even much less exact than a bodily slide rule was, however possibly you continue to benefit from the recollections… The screenshot exhibits how I discovered that 3 instances 7 is approx. 21… (examine 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 Ok  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 <Movement> {.c coords mark %x 0 %x 170; set information [values .c]}
   bind .c <1> {set x %x}
   bind .c <B1-Movement> {%W transfer slide [expr {%x-$x}] 0; set x %x}
   bind . <Shift-Left>  {.c transfer slide -1 0; set information [values .c]}
   bind . <Shift-Proper> {.c transfer slide  1 0; set information [values .c]}
   bind . <Left>  {.c transfer mark -1 0; set information [values .c]}
   bind . <Proper> {.c transfer mark  1 0; set information [values .c]}
proc drawScale {w title label x y dy f from to fac {tag {}}} {
   set colour [expr {[string match -* $f]? "purple": "black"}]
   $w create textual content $x [expr $y+2*$dy] -text $title -tag $tag -fill $colour
   $w create textual content 600 [expr $y+2*$dy] -text $label -tag $tag -fill $colour
   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 {$ipercent10} proceed ;# coarser increments
           set mod 50
       if {$i>1000} {
           if {$ipercent100} proceed ;# 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} proceed
       set lastx $x0
       if {$i%($mod*2)==0 && $firstdigit != $lastlabel} {
           $w create textual content $x0 [expr $y+3*$dy] -text $firstdigit 
              -tag $tag -font {Helvetica 7} -fill $colour
           set lastlabel $firstdigit
       $w create line $x0 $y $x0 $y1 -tag $tag -fill $colour
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     Ok:[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.}}
bind . <Escape> {exec want $argv0 &; exit}

A minimal doodler[edit | edit source]

Here’s a tiny however full script that enables doodling (drawing with the mouse) on a canvas widget:

proc doodle {w {colour black}} {
   bind $w <1>         [list doodle'start %W %x %y $color]
   bind $w <B1-Movement> {doodle'transfer %W %x %y}
proc doodle'begin {w x y colour} {
   set ::_id [$w create line $x $y $x $y -fill $color]
proc doodle'transfer {w x y} {
   $w coords $::_id [concat [$w coords $::_id] $x $y]
pack [canvas .c -bg white] -fill each -expand 1
doodle       .c
bind .c <Double-3> {%W delete all}

And right here it comes once more, however this time with explanations:

The “Utility Program Interface” (API) for this, if you need such ceremonial language, is the doodle command, the place you specify which canvas widget needs to be enabled to doodle, and by which colour (defaults to black):}

proc doodle {w {colour black}} {
   bind $w <1>         [list doodle'start %W %x %y $color]
   bind $w <B1-Movement> {doodle'transfer %W %x %y}

It registers two bindings for the canvas, one (<1>) when the left mouse-button is clicked, and the opposite when the mouse is moved with button 1 (left) down. Each bindings simply name one inner perform every.

On left-click, a line merchandise is created on the canvas within the specified fill colour, however with no extent but, as begin and finish factors coincide. The merchandise ID (a quantity assigned by the canvas) is stored in a worldwide variable, because it should persist lengthy after this process has returned:

proc doodle'begin {w x y colour} {
   set ::_id [$w create line $x $y $x $y -fill $color]

The left-motion process obtains the coordinates (alternating x and y) of the globally identified doodling line object, appends the present coordinates to it, and makes this the brand new coordinates – in different phrases, extends the road to the present mouse place:

proc doodle'transfer {w x y} {
   $w coords $::_id [concat [$w coords $::_id] $x $y]

That is all we have to implement doodling – now let’s create a canvas to check it, and pack it so it may be drawn as large as you want:

pack [canvas .c -bg white] -fill each -expand 1

And this line activates the doodle performance created above (defaulting to black):

doodle       .c

Add a binding for double-right-click/double-button-3, to clear the canvas (added by MG, Apr 29 04)

bind .c <Double-3> {%W delete all}

A tiny drawing program[edit | edit source]

Here’s a tiny drawing program on a canvas. Radio buttons on high enable alternative of draw mode and fill colour. In “Transfer” mode, you possibly can in fact transfer gadgets round. Proper-click on an merchandise to delete it.

A radio is an apparent “megawidget” to carry a row of radiobuttons. This straightforward one permits textual content or colour mode: }

proc radio {w var values {col 0}} {
   body $w
   set kind [expr {$col? "-background" : "-text"}]
   foreach worth $values {
       radiobutton $w.v$worth $kind $worth -variable $var -value $worth 
           -indicatoron 0
       if $col {$w.v$worth config -selectcolor $worth -borderwidth 3}
   eval pack [winfo children $w] -side left
   set ::$var [lindex $values 0]
   set w

Relying on draw mode, the mouse occasions “Down” and “Movement” have totally different handlers, that are dispatched by names that appear like array components. So for a mode X, we’d like a pair of procs, down(X) and transfer(X). Values used between calls are stored in international 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 transfer(Draw) {w x y} {
   $w coords $::ID [concat [$w coords $::ID] $x $y]
#-- Motion of an merchandise
proc down(Transfer) {w x y} {
   set ::ID [$w find withtag current]
   set ::X $x; set ::Y $y
proc transfer(Transfer) {w x y} {
   $w transfer $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
   set ::X $x; set ::Y $y
#-- Clone an present merchandise
proc serializeCanvasItem {c merchandise} {
   set information [concat [$c type $item] [$c coords $item]]
   foreach decide [$c itemconfigure $item] {
       # Embrace any configuration that deviates from the default
       if {[lindex $opt end] != [lindex $opt end-1]} {
           lappend information [lindex $opt 0] [lindex $opt end]
   return $information
proc down(Clone) {w x y} {
   set present [$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 {} transfer(Clone) {} transfer(Transfer)
#-- Drawing a rectangle
proc down(Rect) {w x y} {
   set ::ID [$w create rect $x $y $x $y -fill $::Fill]
proc transfer(Rect) {w x y} {
   $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
#-- Drawing an oval (or circle, when you're cautious)
proc down(Oval) {w x y} {
   set ::ID [$w create oval $x $y $x $y -fill $::Fill]
proc transfer(Oval) {w x y} {
   $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]

Polygons are drawn by clicking the corners. When a nook is shut sufficient to the primary 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 transfer(Poly) {w x y} {#nothing}
#-- With little extra coding, the Fill mode permits altering an merchandise's fill colour:
proc down(Fill) {w x y} {$w itemconfig present -fill $::Fill}
proc transfer(Fill) {w x y} {}
#-- Constructing the UI
set modes {Draw Transfer Clone Fill Rect Oval Poly}
set colours {
   black white magenta brown purple orange yellow inexperienced 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 information
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
#-- The present mode is retrieved at runtime from the worldwide Mode variable:
bind .c <1>         {down($Mode) %W %x %y}
bind .c <B1-Movement> {transfer($Mode) %W %x %y}
bind .c <3>         {%W delete present}

For saving the present picture, you want the Img extension, so simply omit the next binding if you do not have Img:

bind . <F1> {
   package deal require Img
   set img [image create photo -data .c]
   set title [tk_getSaveFile -filetypes {{GIFF .gif} {"All files" *}}
       -defaultextension .gif]
   if {$title ne ""} {$img write $title; wm title . $title}
#-- That is an at all times helpful helper in growth:
bind . <Escape> {exec want $argv0 &; exit}

A minimal editor[edit | edit source]

Here is an completely easy editor, in 26 traces of code, which simply permits to load and save recordsdata, and naturally edit, and lower and paste, and no matter is built-in into the textual content widget anyway. And it has a bit “on-line assist”… 😉

It’s at all times a good suggestion to begin a supply file with some explanations on the title, objective, writer, and date. I’ve not too long ago picked up the behavior to place this data right into a string variable (which in Tcl can simply span a number of traces), so the identical information is offered to the reader of the supply code, and may be displayed as on-line assist: }

set about "minEd - a minimal editor
Richard Suchenwirth 2003
F1: assist
F2: load
F3: save

The seen a part of a Graphical Person Interface (GUI) consists of widgets. For this editor, I in fact want a textual content widget, and a vertical scrollbar. With the choice “-wrap phrase” for the textual content widget, one other horizontal scrollbar shouldn’t be wanted – traces longer than the window simply wrap at phrase boundaries.

Tk widgets come on the display in two steps: first, they’re created with an preliminary configuration; then, handed to a “geometry supervisor” for show. As widget creation instructions return the pathname, they are often nested into the supervisor command (pack on this case), to maintain all settings for a widget in a single place. This will likely result in over-long traces, although.

Though the scrollbar involves the precise of the textual content, I create and pack it first. The reason being that when a window is made smaller by the consumer, the widgets final packed first lose visibility.

These two traces additionally 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 modified, for example from cursor keys

And these two traces already give us an editor for arbitrarily lengthy textual content, with built-in capabilities of lower, copy, and paste – see the textual content man web page. Solely file I/O needs to be added by us to make it actually usable.

pack [scrollbar .y -command ".t yview"] -side proper -fill y
pack [text .t -wrap word -yscrollc ".y set"] -side proper -fill each -expand 1

Are you targetting 8.4 or later? If that’s the case, add -undo 1 to the choices to textual content and get full undo/redo help!

pack [text .t -wrap word -yscrollc ".y set" -undo 1] -side proper -fill each -expand 1

The opposite necessary a part of a GUI are the bindings – what occasion shall set off what motion. For simplicity, I’ve restricted the bindings right here to a couple of the perform keys on high of typical keyboards:

bind . <F1> {tk_messageBox -message $about}

On-line assist is finished with a no-frills tk_messageBox with the “about” textual content outlined at begin of file. – The opposite bindings name customized instructions, which get a filename argument from Tk’s file selector dialogs:

bind . <F2> {loadText .t [tk_getOpenFile]}
bind . <F3> {saveText .t [tk_getSaveFile]}

These dialogs can be configured in a variety of methods, however even on this easy type they’re fairly highly effective – enable navigation across the file system, and many others. On Home windows they name the native file selectors, which have a historical past of beforehand opened recordsdata, element view (measurement/date and many others.)

When this editor known as with a filename on the command line, that file is loaded on startup (easy as it’s, it could actually solely deal with one file at a time):

if {$argv != ""} {loadText .t [lindex $argv 0]}

The procedures for loading and saving textual content each begin with a sanity examine of the filename argument – if it is an empty string, as produced by file selector dialogs when the consumer cancels, they return instantly. In any other case, they switch file content material to textual content widget or vice-versa. loadText provides the “luxurious” that the title of the present file can be put into the window title. Then it opens the file, clears the textual content widget, reads all file contents in a single go, and places them into the textual content widget.

proc loadText {w fn} {
   if {$fn==""} return
   wm title . [file tail $fn]
   set fp [open $fn]
   $w delete 1.0 finish
   $w insert finish [read $fp]
   shut $fp

saveText takes care to not save the additional newline that textual content widgets append at finish, by limiting the vary to “finish – 1 c”(haracter).

proc saveText {w fn} {
   if {$fn==""} return
   set fp [open $fn w]
   places -nonewline $fp [$w get 1.0 "end - 1 c"]
   shut $fp

File watch[edit | edit source]

Some editors (e.g. PFE, MS Visible Studio) pop up an alert dialog when a file was modified on disk whereas being edited – which may result in edit conflicts. Emacs exhibits a extra delicate warning on the first try to alter a file that has modified on disk.

Right here I attempt to emulate this function. It’s oversimplified as a result of it doesn’t replace the mtime (file modification time) to examine, when you saved it from the editor itself. So make certain to name textual content’watch’file once more after saving.

Utilizing the worldwide variable ::_twf it’s not less than potential to keep away from false alarms – for a extra critical implementation one may use a namespaced array of watchers, listed by file title, in case you need a number of edit home windows. }

proc textual content'watch'file {w file {mtime -}} {
   set checkinterval 1000 ;# modify as wanted
   if {$mtime eq "-"} {
       if [info exists ::_twf] {after cancel $::_twf}
       set file [file join [pwd] $file]
       textual content'watch'file $w $file [file mtime $file]
   } else {
       set newtime [file mtime $file]
       if {$newtime != $mtime} {
           set reply [tk_messageBox -type yesno -message 
               "The filen$filenhas changed on disk. Reload it?"]
           if {$reply eq "sure"} {textual content'learn'file $w $file}
           textual content'watch'file $w $file
       } else {set ::_twf [after $checkinterval [info level 0]]}
proc textual content'learn'file {w file} {
   set f [open $file]
   $w delete 1.0 finish
   $w insert finish [read $f]
   shut $f
#-- Testing:
pack [text .t -wrap word] -fill each -expand 1
set file textwatch.tcl
textual content'learn'file  .t $file
textual content'watch'file .t $file

The dialog ought to come up while you change the file externally, say by touch-ing it in pure Tcl, which could be completed with enhancing it in one other editor, or

file mtime $filename [clock seconds]

Tiny presentation graphics[edit | edit source]

This can be a crude little canvas presentation graphics that runs on PocketPCs, but in addition on larger bins (one may scale fonts and dimensions there). Swap pages with Left/Proper cursor, or left/proper mouseclick (although a stylus can’t right-click).

Not many options, however the code may be very compact, and with a cute little language for content material specification, see instance at finish (which exhibits what I offered on the 2003 Euro-Tcl conference in Nuremberg…)}

proc slide args {
  international slides
  if {![info exist slides]} slide'init
  incr slides(N)
  set slides(title,$slides(N)) [join $args]
proc slide'line {kind args} {
  international slides
  lappend slides(physique,$slides(N)) [list $type [join $args]]
foreach title {* + -} {interp alias {} $title {} slide'line $title}
proc slide'init {} {
  international slides
  array set slides {
     canvas .c  N 0  present 1 dy 20
     titlefont {Tahoma 22 daring} * {Tahoma 14 daring} + {Tahoma 12}
     - {Courier 10}
  pack [canvas .c -bg white] -expand 1 -fill each
  foreach e {<1> <Proper>} {bind . $e {slide'present 1}}
  foreach e {<3> <Left>} {bind . $e {slide'present -1}}
  wm geometry . +0+0
  after idle {slide'present 0}
proc slide'present delta {
  upvar #0 slides s
  incr s(present) $delta
  if  $s(present)>$s(N) {
     incr s(present) [expr -$delta]
  } else {
     set c $s(canvas)
     $c delete all
     set x 10; set y 20
     $c create textual content $x $y -anchor w -text $s(title,$s(present))
        -font $s(titlefont) -fill blue
     incr y $s(dy)
     $c create line $x $y 2048 $y -fill purple -width 4
     foreach line $s(physique,$s(present)) {
        foreach {kind textual content} $line break
        incr y $s(dy)
        $c create textual content $x $y -anchor w -text $textual content 
        -font $s($kind)
bind . <Up> {exec want $argv0 &; exit} ;# dev helper

The remainder is information – or is it code? Anyway, this is my present:

slide i18n - Tcl for the world
+ Richard Suchenwirth, Nuremberg 2003
* i18n: internationalization
+ 'make software program work with many languages'
* l10n: localization
+ 'make software program work with the native language'
slide Terminology
* Glyphs:
+ seen components of writing
* Characters:
+ summary components of writing
* Byte sequences:
+ bodily textual content information illustration
* Rendering: character -> glyph
* Encoding: character <-> byte sequence
slide Earlier than 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, Home windows
* ISO 8859-x: 16 varieties
slide East Asia
* Hundreds of characters/nation
+ Resolution: 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
* Frequent customary of software program trade
* stored in synch with ISO 10646
+ Was 16 bits, till U 3.1
+ Now wants as much as 31 bits
* Byte order drawback:
+ little-endian/big-endian
+ U+FEFF "Byte Order Mark"
+ U+FFFE --illegal--
slide UTF-8
* Various size: 1..3(..6) bytes
+ 1 byte: ASCII
+ 2 bytes: pages 00..07, Alphabets
+ 3 bytes: pages 08..FF, remainder of BMP
+ >3 bytes: increased pages
* Customary in XML, coming in Unix
slide Tcl i18n
* Every part is a Unicode string (BMP)
+ inner rep: UTF-8/UCS-2
* Vital instructions:
- fconfigure $ch -encoding $e
- encoding convertfrom $e $s
- encoding convertto   $e $s
* msgcat helps l10n:
- {"File" -> [mc "File"]}
slide Tk i18n
* Any widget textual content is Unicoded
* Computerized font discovering
+ Fonts have to be offered by system
* Lacking: bidi therapy
+ right-to-left conversion (ar,he)
slide Enter i18n
* Keyboard rebinding (bindtags)
* East Asia: keyboard buffering
+ Menu choice for ambiguities
* Digital keyboard (buttons, canvas)
* String conversion: *lish household
- {[ruslish Moskva]-[greeklish Aqh'nai]}
slide i18n - Tcl for the world
+ Thanks.

Timeline show[edit | edit source]

One more factor to do with a canvas: historical past visualisation of a horizontal time-line, for which a 12 months scale is displayed on high. The next sorts of objects are thus far out there:

  • “eras”, displayed in yellow under the timeline in bins
  • “background gadgets” which can be gray and stretch over all of the canvas in top
  • regular gadgets, which get displayed as stacked orange bars

You may zoom in with <1>, out with <3> (each solely in x route). On mouse movement, the present 12 months is displayed within the toplevel’s title. Regular gadgets generally is a single 12 months, just like the Columbus instance, or a variety of years, for example for lifetimes of individuals. (The instance exhibits that Mozart did not dwell lengthy…)

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 {$xpercent50 == 0} {
           $w create line $x 8 $x 0
           $w create textual content $x 8 -text $x -anchor n
       } else {
           $w create line $x 5 $x 0
   bind $w <Movement> {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 transfer 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 purple
proc timeliner::title {w x} {
   variable ""
   wm title . [expr int([$w canvasx $x]/$(-zoom))]
proc timeliner::zoom {w x issue} {
   variable ""
   $w scale all 0 0 $issue 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 purple

This command provides an object to the canvas. The code for “merchandise” took me some effort, because it needed to find a free “slot” on the canvas, looking out top-down:

proc timeliner::add {w kind title 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)}]
   change -- $kind {
       period    {set fill yellow; set define black; set y0 20; set y1 40}
       bgitem {set fill grey; set define {}; set y0 40; set y1 1024}
       merchandise   {
           set fill orange
           set define 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 {$kind eq "bgitem"} {$w decrease $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] daring"
   $w config -scrollregion [$w bbox all]

Here is a pattern utility, that includes a concise historical past of music when it comes to composers:

scrollbar .x -ori hori -command {.c xview}
pack      .x -side backside -fill x
canvas    .c -bg white -width 600 -height 300 -xscrollcommand {.x set}
pack      .c -fill each -expand 1
timeliner::create .c -from 1400 -to 2000

These nifty shorthands for including gadgets make information specification a breeze – evaluate the unique name, and the shorthand:

   timeliner::add .c merchandise Purcell 1659-1695
   - Purcell 1659-1695

With a further “!” argument you can also make the textual content of an merchandise daring:

foreach {shorthand kind} {* period  x bgitem - merchandise} {
   interp alias {} $shorthand {} timeliner::add .c $kind

Now for the info to show (written fairly readably):

See Also

* {Center 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 struggle} 1618-1648
* {Basic period}  1750-1810
- Haydn 1732-1809 !
- Boccherini 1743-1805
- Mozart 1756-1791 !
- Beethoven 1770-1828 !
* {Romantic period} 1810-1914
- {Mendelssohn Bartholdy} 1809-1847
- Chopin 1810-1849
- Liszt 1811-1886
- Verdi 1813-1901
x {French revolution} 1789-1800
* {Fashionable period}   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

Enjoyable with capabilities[edit | edit source]

My teenage daughter hates math. So as to encourage her, I beefed up an earlier little perform plotter which earlier than solely took one perform, in strict Tcl (expr) notation, from the command line. Now there’s an entry widget, and the accepted language has additionally been enriched: past exprs guidelines, you possibly can omit greenback and multiplication indicators, like 2x+1, powers may be written as x3 as an alternative of ($x*$x*$x); in easy circumstances you possibly can omit parens spherical perform arguments, like sin x2. Hitting <Return> within the entry widget shows the perform’s graph.

If you happen to want some concepts, click on on the “?” button to cycle by way of a set of demo capabilities, from boring to weird (e.g. if rand() is used). Apart from default scaling, you possibly can zoom in or out. Transferring the mouse pointer over the canvas shows x and y coordinates, and the show adjustments to white when you’re on a degree on the curve.

The goal was not reached: my daughter nonetheless hates math. However not less than I had hours of Tcl (and performance) enjoyable once more, browsing within the Cartesian aircraft… hope you take pleasure in it too!

proc primary {} {
   canvas .c -bg white -borderwidth 0
   bind   .c <Movement> {displayXY .information %x %y}
   body  .f
     label  .f.1 -text "f(x) = "
     entry  .f.f -textvar ::perform -width 40
       bind .f.f <Return> {plotf .c $::perform}
     button .f.demo -text " ? " -pady 0 -command {demo .c}
     label  .f.2 -text " Zoom: "
     entry  .f.fac -textvar ::issue -width 4
       set                  ::issue 32
       bind .f.fac <Return>               {zoom .c 1.0}
     button  -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 each
   label  .information -textvar ::information -just left
   pack .information .f -fill x -side backside
   pack .c -fill each -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"
       spherical(x) "int xpercent2" "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 "9percentint x"
       0.5x2/(x3-3x2+4) "abs x2-3 int x" "int xpercent3"
proc displayXY {w cx cy} {
       set x [expr {double($cx-$::dx)/$::factor}]
       set y [expr {double(-$cy+$::dy)/$::factor}]
       set ::information [format "x=%.2f y=%.2f" $x $y]
       catch {
       $w config -fg [expr {abs([expr $::fun]-$y)<0.01?"white":"black"}]
       } ;# might divide by zero, or different unlawful issues
proc zoom {w howmuch} {
   set ::issue [expr round($::factor*$howmuch)]
   plotf $w $::perform
proc plotf {w perform} {
   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 $perform $subst perform}
   set ::enjoyable $perform
   set ::information "Tcl: expr $::enjoyable"
   set colour [lpick {red blue purple brown green}]
   plotline $w [fun2points $::fun] -fill $colour
proc lpick L {lindex $L [expr {int(rand()*[llength $L])}]}
proc fun2points {enjoyable args} {
   array set decide {-from -10.0 -to 10.0 -step .01}
   array set decide $args
   set res "{"
   for {set x $decide(-from)} {$x<= $decide(-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 factors args} {
   $w delete all
   foreach i $factors {
       if {[llength $i]>2} {eval $w create line $i $args -tags f}
   set fac $::issue
   $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 transfer all $::dx $::dy
   $w increase f
proc demo {w} {
   set ::perform [lindex $::demos 0] ;# cycle by way of...
   set ::demos [concat [lrange $::demos 1 end] [list $::function]]
   set ::issue 32
   plotf $w $::perform

Practical imaging[edit | edit source]

In Conal Elliott’s Pan mission (“Practical Picture Synthesis”, [1]), pictures (of arbitrary measurement and backbone) are produced and manipulated in a sublime practical method. Capabilities written in Haskell (see Enjoying Haskell) are utilized, largely in practical composition, to pixels to return their colour worth. FAQ: “Can we now have that in Tcl too?”

Because the funimj demo under exhibits, in precept sure; nevertheless it takes some persistence (or a really quick CPU) – for a 200×200 picture the perform known as 40000 instances, which takes 9..48 seconds on my P200 field. Nonetheless, the output typically is value ready for… and the time used to put in writing this code was negligible, because the Haskell authentic might with few modifications be represented in Tcl. Practical composition needed to be rewritten to Tcl’s Polish notation – Haskell’s

foo 1 o bar 2 o grill

(the place “o” is the composition operator) would in Tcl appear like

o {foo 1} {bar 2} grill

As the instance exhibits, extra arguments may be specified; solely the final argument is handed by way of the generated “perform nest”:

proc f {x} {foo 1 [bar 2 [grill $x]]}

However the title of the generated perform is far nicer than “f”: particularly, the whole name to “o” is used, so the instance proc has the title

"o {foo 1} {bar 2} grill"

which is fairly self-documenting 😉 I carried out “o” like this:

proc o args {
   # mix the capabilities in args, return the created title
   set title [info level 0]
   set physique "[join $args " ["] $x"
   append physique [string repeat ] [expr {[llength $args]-1}]]
   proc $title x $physique
   set title
# Now for the rendering framework:
proc fim {f {zoom 100} {width 200} {top -}} {
   # produce a photograph picture by making use of perform f to pixels
   if {$top=="-"} {set top $width}
   set im [image create photo -height $height -width $width]
   set information {}
   set xs {}
   for {set j 0} {$j<$width} {incr j} {
       lappend xs [expr {($j-$width/2.)/$zoom}]
   for {set i 0} {$i<$top} {incr i} {
       set row {}
       set y [expr {($i-$height/2.)/$zoom}]
       foreach x $xs {
           lappend row [$f [list $x $y]]
       lappend information $row
   $im put $information
   set im

Fundamental imaging capabilities (“drawers”) have the widespread performance level -> colour, the place level is a pair {x y} (or, after making use of a polar rework, {r a}…) and colour is a Tk colour title, like “inexperienced” or #010203:

proc  vstrip p {
   # a easy 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 a 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 beginning 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 {
   # colour gradients - finest 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

Past the examples in Conal Elliott’s paper, I discovered that perform imaging can be abused for a (gradual and imprecise) perform plotter, which shows the graph for y = f(x) when you name 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 right here!

Here’s a combinator for 2 binary pictures that exhibits in several colours for which level each or both are “true” – good however gradual:}

proc bin2 {f1 f2 p} {
   set a [eval $f1 [list $p]]
   set b [eval $f2 [list $p]]
   expr {
       $a == "#000" ?
           $b == "#000" ? "inexperienced"
           : "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 colour title: {0 128 255} -> #0080FF
   format #%02Xpercent02Xpercent02X $r $g $b
proc bPaint {color0 color1 pixel} {
   # convert a binary pixel to certainly one of two specified colours
   expr {$pixel=="#000"? $color0 : $color1}

This painter colours a grayscale picture in hues of the given colour. It normalizes the given colour by way of dividing by the corresponding values for “white”, however seems fairly gradual too:

proc gPaint {colour 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 outcomes of [winfo rgb] calls, as a result of these are fairly costly, particularly on distant X shows – rmax

proc rgb {colour} {
   upvar "#0" rgb($colour) rgb
   if {![info exists rgb]} {set rgb [winfo rgb . $color]}
   set rgb
#------------------------------ level -> level transformers
proc fromPolars p {
   foreach {r a} $p break
   listing [expr {$r*cos($a)}] [expr {$r*sin($a)}]
proc toPolars p {
   foreach {x y} $p break
   # for Solar, we now have to ensure atan2 will get no two 0's
   listing [expr {hypot($x,$y)}] [expr $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
   listing $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)}]
   listing $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 exhibits the predefined primary picture operators, and a few combos, on a button bar. Click on on one, have some persistence, and the corresponding picture will likely be displayed on the canvas to the precise. You may also experiment with picture operators within the entry widget at backside – hit <Return> to strive. The textual content of pattern buttons can be copied to the entry widget, so you possibly can play with the parameters, or rewrite it as you want. Observe {that a} well-formed funimj composition consists of:

  • the composition operator “o”
  • zero or extra “painters” (colour -> colour)
  • one “drawer” (level -> colour)
  • zero or extra “transformers” (level -> level)


proc fim'present {c f} {
   $c delete all
   set ::strive $f ;# put together for enhancing
   set t0 [clock seconds]
   . config -cursor watch
   replace ;# to make the cursor seen
   $c create picture 0 0 -anchor nw -image [fim $f $::zoom]
   wm title . "$f: [expr [clock seconds]-$t0] seconds"
   . config -cursor {}
 proc fim'strive {c varName} {
   upvar #0 $varName var
   $c delete all
   if [catch {fim'show $c [eval $var]}] {
       $c create textual content 10 10 -anchor nw -text $::errorInfo

Composed capabilities want solely be talked about as soon as, which creates them, and so they can later be picked up by information procs. The o appears properly bullet-ish right 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 purple} gRings
o {bin2 {radReg 7} udisk}
#----------------------------------------------- testing
body .f2
set c [canvas .f2.c]
set e [entry .f2.e -bg white -textvar try]
bind $e <Return> [list fim'try $c ::try]
scale .f2.s -from 1 -to 100 -variable zoom -ori hori -width 6
#--------------------------------- button bar:
body .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 high -fill x -ipady 0
eval pack [winfo children .f2] -side high -fill x
pack .f .f2 -side left -anchor n
bind . <Escape> {exec want $argv0 &; exit} ;# dev helper
bind . ? {console present} ;# dev helper, Win/Mac solely

TkPhotoLab[edit | edit source]

The next code can be utilized for experiments in picture processing, together with

  • convolutions (see under)
  • conversion from colour to greylevel
  • conversion from greylevel to fake colour
  • brightness and distinction modification

Tcl shouldn’t be the quickest in heavy number-crunching, as wanted when going over many hundreds of pixels, however I would not take into account C for a enjoyable mission 😉 So take your time, or get an actual CPU. At the very least you possibly can watch the progress, because the goal picture is up to date after each row.


Edge enhancement by Laplace5 filter

The demo UI exhibits two pictures, the unique on the left, the processing end result on the precise. You may push the end result to the left with Choices/Settle for. See the menus for what goodies I’ve provided. However what most me have been “convolutions”, for which you’ll be able to edit the matrix (fastened at 3×3 – gradual sufficient..) and click on “Apply” to run it over the enter picture. “C” to set the matrix to all zeroes.

Convolution is a method the place a goal pixel is coloured in response to the sum of the product of a given matrix and its neighbors. For instance, the convolution matrix

1 1 1
1 1 1
1 1 1

colours the pixel within the center with the typical of itself and its eight neighbors, which can myopically blur the image.

0 0 0
0 1 0
0 0 0

ought to simply faithfully repeat the enter image. These

0  -1  0       -1 -1 -1
-1  5 -1  or:  -1  9 -1
0  -1  0       -1 -1 -1

improve {horizont,vertic}al edges, and make the picture 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 okay {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
       replace idletasks
proc alias {title args} {eval [linsert $args 0 interp alias {} $name {}]}
alias rgb   format #%02xpercent02xpercent02x
proc lambda {argl physique} {Ok [set n [info level 0]] [proc $n $argl $body]}
proc Ok      {a b} {set a}
proc clip   x {expr {$x>255? 255: $x<0? 0: int($x)}}
proc photo2matrix picture {
   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 certain all matrix components add as much as 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 next routines is also generified into one:

proc color2gray picture {
   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]
       $picture put [list $row] -to 0 $i
       replace idletasks
proc color2gray2 picture {
   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]
       $picture put [list $row] -to 0 [incr i]
       replace idletasks

An experiment in classifying graylevels into unreal colours:

proc gray2color picture {
   set i -1
   set colours {black darkblue blue purple purple 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]
       $picture put [list $row] -to 0 [incr i]
       replace idletasks
proc grayWedge picture {
   $picture clean
   for {set i 0} {$i<256} {incr i} {
       $picture put [rgb $i $i $i] -to $i 0 [expr {$i+1}] 127

Quite a few algorithms are very related, distinguished solely by a couple of instructions within the heart. Therefore I made them generic, and so they take a perform title that’s utilized to each pixel rgb, resp. a pair of pixel rgb’s. They’re instantiated by an alias that units the perform fancily as a lambda:

proc generic_1 {f goal supply} {
   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]]
       $goal put [list $row] -to 0 $i
       replace idletasks
alias invert    generic_1 [lambda x {expr {255-$x}}]
alias distinction+ 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 goal 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]]
       $goal put [list $row] -to 0 $i
       replace idletasks
alias mix      generic_2 [lambda {a b} {expr {($a+$b)/2}}]
alias distinction generic_2 [lambda {a b} {expr {255-abs($a-$b)}}]

A histogram is a depend of which colour worth occurred how typically within the present picture, individually for purple, inexperienced and blue. For graylevel pictures, the displayed “curves” ought to precisely overlap, so that you see solely the blue dots which can be drawn final.

proc histogram {picture {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 {goal enter} {
   $goal clean
   set a [expr {6000./([image height $input]*[image width $input])}]
   foreach colour {purple inexperienced blue} channel {0 1 2} {
       set i -1
       foreach val [histogram $input $channel] {
           $goal put $colour -to [incr i] 
               [clip [expr {int(128-$val*$a)}]]
       replace idletasks

Demo UI:

if {[file tail [info script]] eq [file tail $argv0]} {
   package deal require Img ;# for JPEG and many others.
   proc setFilter {w matrix} {
       $w delete 1.0 finish
       foreach row $matrix {$w insert finish [join $row t]n}
       set ::information "Click on 'Apply' to make use of this filter"
   label .title -text TkPhotoLab -font {Helvetica 14 italic} -fg blue
   label .( -text ( -font {Courier 32}
   set txt [text .t -width 20 -height 3]
   setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}
   label .) -text ) -font {Courier 32}
   button .c -text C -command {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
   grid .title .( .t .) .c -sticky information
   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 ::information "Loaded picture 1 from $fn"
   proc saveImg { {fn ""}} {
       if {$fn==""} {set fn [tk_getSaveFile]}
       if {$fn != ""} {
           $::im2 write $fn -format JPEG
           set ::information "Saved picture 2 to $fn"
   proc applyConv {} {
       set ::information "Convolution working, have persistence..."
       set t0 [clock clicks -milliseconds]
       convolute $::im1 $::im2 [split [$::txt get 1.0 end] n]
       set dt [expr {([clock click -milliseconds]-$t0)/1000.}]
       set ::information "Prepared after $dt sec"

A little bit wrapper for simplified menu creation – see under for its use:

   proc m+ {head title {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 $title -comm $cmd}
   . config -menu [menu .m]
   m+ File Open.. loadImg
   m+ File Save.. saveImg
   m+ File ---
   m+ File Exit   exit
   m+ Edit Mix      {mix $im2 $im1}
   m+ Edit Distinction {distinction $im2 $im1}
   m+ Edit ---
   m+ Edit Unfavorable   {invert     $im2 $im1}
   m+ Edit Distinction+  {distinction+  $im2 $im1}
   m+ Edit Distinction-  {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 "The other way up" {$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+ Choices "Settle for (1<-2)" {$im1 copy $im2 -shrink}
   m+ Choices ---
   m+ Choices "Grey wedge" {grayWedge $im2}
   m+ Choices Histogram  {drawHistogram $im2 $im1}
   m+ Filter Clear {setFilter .t {{0 0 0} {0 0 0} {0 0 0}}}
   m+ Filter ---
   m+ Filter Blur0  {setFilter .t {{1 1 1} {1 0 1} {1 1 1}}}
   m+ Filter Blur1  {setFilter .t {{1 1 1} {1 1 1} {1 1 1}}}
   m+ Filter Gauss2 {setFilter .t {{1 2 1} {2 4 2} {1 2 1}}}
   m+ Filter ---
   m+ Filter Laplace5 {setFilter .t {{0 -1 0} {-1 5 -1} {0 -1 0}}}
   m+ Filter Laplace9 {setFilter .t {{-1 -1 -1} {-1 9 -1} {-1 -1 -1}}}
   m+ Filter LaplaceX {setFilter .t {{1 -2 1} {-2 5 -2} {1 -2 1}}}
   m+ Filter ---
   m+ Filter Emboss   {setFilter .t {{2 0 0} {0 -1 0} {0 0 -1}}}
   m+ Filter HoriEdge {setFilter .t {{-1 -1 -1} {0 0 0} {1 1 1}}}
   m+ Filter VertEdge {setFilter .t {{-1 0 1} {-1 0 1} {-1 0 1}}}
   m+ Filter SobelH   {setFilter .t {{1 2 1} {0 0 0} {-1 -2 -1}}}
   m+ Filter SobelV   {setFilter .t {{1 0 -1} {2 0 -2} {1 0 -1}}}
   bind . <Escape> {exec want $argv0 &; exit}
   bind . <F1> {console present}
   loadImg aaa.jpg

Source Link

What's Your Reaction?
In Love
Not Sure
View Comments (0)

Leave a Reply

Your email address will not be published.

2022 Blinking Robots.
WordPress by Doejo

Scroll To Top